窗体自带滚动条的问题

[ccbbcc]

我写了个VB界面，一个窗体在800*600分辨率中不能显示全。
我在网上找了个例子，如下：
模块代码：
'从1.窗口风格的设置直到此处都可以直接COPY到窗口代码中


'5.消息响应机制
'添加一个公共模块,在模块中加入以下代码和声明
Public Const SM_CXHSCROLL = 21
Public Const GWL_STYLE = (-16)
Public Const WS_HSCROLL = &H100000
Public Const WS_VSCROLL = &H200000
Public Const SB_BOTH = 3
Public Const SB_HORZ = 0
Public Const SB_VERT = 1
'以下以SB_开头的是用户的滚动请求
Public Const SB_LINEDOWN = 1
Public Const SB_LINELEFT = 0
Public Const SB_LINERIGHT = 1
Public Const SB_LINEUP = 0
Public Const SB_PAGERIGHT = 3
Public Const SB_PAGELEFT = 2
Public Const SB_PAGEDOWN = 3
Public Const SB_PAGEUP = 2
Public Const SB_ENDSCROLL = 8
Public Const SB_THUMBPOSITION = 4
Public Const SB_THUMBTRACK = 5
Public Const GWL_WNDPROC = (-4)
Public Const WM_HSCROLL = &H114
Public Const WM_VSCROLL = &H115
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function ShowScrollBar Lib "user32" (ByVal hWnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long
Declare Function SetScrollPos Lib "user32" (ByVal hWnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
Declare Function SetScrollRange Lib "user32" (ByVal hWnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public preWndProc As Long
Public xMin As Integer, xMax As Integer
Public yMin As Integer, yMax As Integer
Public xPos As Integer, yPos As Integer

Public Function WindowProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
Dim xInc As Integer, yInc As Integer
Select Case uMsg
Case WM_VSCROLL '垂直滚动条消息
Select Case LoWord(wParam)
Case SB_LINEUP, SB_LINEDOWN
If LoWord(wParam) Then
yInc = 1
Else
yInc = -1
End If
Case SB_PAGEUP, SB_PAGEDOWN
If LoWord(wParam) = SB_PAGEUP Then
yInc = -10
Else
yInc = 10
End If


Case SB_THUMBTRACK
yInc = HiWord(wParam) - yPos
End Select
yPos = yPos + yInc
If yPos < yMin Then yPos = yMin
If yPos > yMax Then yPos = yMax
SetScrollPos hWnd, SB_VERT, yPos, True
Form1.Label1 = yPos
Case WM_HSCROLL '垂直水平条消息
Select Case LoWord(wParam)
Case SB_LINELEFT, SB_LINERIGHT
If LoWord(wParam) Then
xInc = 1
Else
xInc = -1
End If
Case SB_PAGELEFT, SB_PAGERIGHT
If LoWord(wParam) = SB_PAGELEFT Then
xInc = -10
Else
xInc = 10
End If
Case SB_THUMBTRACK
xInc = HiWord(wParam) - xPos
End Select
xPos = xPos + xInc
If xPos < xMin Then xPos = xMin
If xPos > xMax Then xPos = xMax
SetScrollPos hWnd, SB_HORZ, xPos, True
Form1.Label2 = xPos
End Select
WindowProc = CallWindowProc(preWndProc, hWnd, uMsg, wParam, lParam)
End Function
Public Sub SubClass(frm As Form)
preWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf WindowProc)
'preWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, 1)
End Sub
Public Sub UnSubClass(frm As Form)
Call SetWindowLong(frm.hWnd, GWL_WNDPROC, preWndProc)
End Sub
'The function below is much useful in API development.
Private Function LoWord(num As Long) As Integer
LoWord = num Mod &H10000
End Function
Private Function HiWord(num As Long) As Integer
HiWord = (num And &HFFFF0000) / &H10000
End Function



窗体代码：
Dim x As Integer, y As Integer
'1.窗口风格的设置
'在窗口声明部分加入
Dim HVisible As Boolean, VVisible As Boolean
Dim OldStyle As Long
Dim hsWidth As Integer
'保存旧风格
OldStyle = SetWindowLong(hWnd, GWL_STYLE, 0)
'设置新风格
Call SetWindowLong(hWnd, GWL_STYLE, OldStyle Or WS_VSCROLL Or WS_HSCROLL)
VVisible = True
HVisible = True
ShowScrollBar hWnd, SB_VERT, True
VVisible = True

'得到水平滚动条的宽度
hsWidth = GetSystemMetrics(SM_CXVHSCROLL)
'改变窗口宽度与高度
Width = Width + hsWidth
Height = Height + hsHeight
VVisible = True
'HVisible = True
'怎么样,滚动条显示出来了没有?没有?那么是我眼花了?@_@


'2.滚动范围的设置
YMin = 0: YMax = 100
'XMin = 0: XMax = 100
'SetScrollRange hWnd, SB_HORZ, XMin, XMax, True
SetScrollRange hWnd, SB_VERT, YMin, YMax, True
'建立子类窗口
'SubClass Me
可是调试时，发现点击滚动条窗体没有滚动效果。
请高手帮忙，谢谢！

[脆皮大雪糕]

800*600 的分辨率……
我还以为这种东西已经绝迹了

[脆皮大雪糕]

窗体里加下面这写代码，或者在相应的事件里加入相应的代码。
看看能否满足你的应用场景。

Option Explicit
Private Type TControlInfo
    ctrl As Control
    Left As Single
    Top As Single
    Width As Single
    Height As Single
    FontSize As Single
End Type
Private mlngW As Long
Private mlngh  As Long
Dim SaveCtrl() As TControlInfo
 
Private Sub Form_Initialize()
    On Error Resume Next
    mlngW = Me.Width
    mlngh = Me.Height
    '保存控件的状态
    ReDim SaveCtrl(Me.Controls.Count - 1) As TControlInfo
    Dim i As Integer
    Dim ctrl As Control
    For i = 0 To Me.Controls.Count - 1
        Set ctrl = Me.Controls(i)
        With SaveCtrl(i)
            Set .ctrl = ctrl
            .Left = ctrl.Left
            .Top = ctrl.Top
            .Width = ctrl.Width
            .Height = ctrl.Height
            .FontSize = ctrl.Font.Size
        End With
    Next
End Sub
 
Private Sub Form_Resize()
    On Error Resume Next
    Dim lngW As Long
    Dim lngh  As Long
    Dim lngf As Single
    Dim i As Integer
 
    lngW = Me.Width
    lngh = Me.Height
     
    If (lngW / mlngW) < (lngh / mlngh) Then
        lngf = (lngW / mlngW)
    Else
        lngf = (lngh / mlngh)
    End If
     
 
   For i = 0 To UBound(SaveCtrl)
      With SaveCtrl(i)
       
            If .ctrl.Left < 0 Then
               .ctrl.Left = ((.ctrl.Left + 75000) * (lngW / mlngW)) - 75000
            ElseIf .Left < 0 Then
               .ctrl.Left = (.Left + 75000) * (lngW / mlngW)
            Else
               .ctrl.Left = .Left * (lngW / mlngW)
            End If
            .ctrl.Top = .Top * (lngh / mlngh)
            .ctrl.Width = .Width * (lngW / mlngW)
            .ctrl.Height = .Height * (lngh / mlngh)
            '控件字体自适应大小
            If .FontSize > 0 Then
               If (.FontSize * lngf) < 8 Then
                  If (.FontSize * lngf) > 7 Then
                     .ctrl.Font.Size = 7
                  Else
                     .ctrl.Font.Size = .FontSize * lngf
                  End If
               Else
                 .ctrl.Font.Size = .FontSize * lngf
               End If
            End If
      End With
   Next
End Sub

[ccbbcc]

如果不好在这个基础上改，提供个别的思路也行

[舉杯邀明月]

引用 1 楼 ccbbcc 的回复:

如果不好在这个基础上改，提供个别的思路也行

不知道你说的“点击滚动条窗体没有滚动效果”，指的是什么。
如果你是想说，你点击（或拖动）滚动条，
　　它就“自动把窗体显示内容”进行相应的滚动显示。那明摆着是不可能的！
你必须“按滚动条的值”，自己去处理“滚动内容显示”，
　　比如说，按当前垂直滚动条的值、窗口高度，
　　计算一下，哪些控件能在“可见”的区域内、各个控件的Top值对应为多少（要把Top属性进行更改）。

你贴出来的代码，不太完整，也有一些错误。
比如，你的“窗体代码”在重新计算窗体大小时，就是错误的算法。
　　　　当然还有别的一些错误…………

我做了个简单的测试工程，修正代码，可以看到：
　在改变垂直滚动条的值之后，窗体内是“实时更新”的显示出了滚动条的值。
　只要在这个“消息”中，自己再进行正确的“回调处理”，就能实现要求了。