VB通过子类化添加滚动条

'在窗体添加两个Label和两个Command
'FORM
Option Explicit
'在窗口声明部分加入
Dim HVisible As Boolean, VVisible As Boolean, hsHeight

Private Sub Form_Load()
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)
Command1.Caption = “隐藏垂直滚动条”
Command2.Caption = “隐藏水平滚动条”
Label1 = “垂直滚动条的值”
Label2 = “水平滚动条的值”
'得到水平滚动条的宽度
hsWidth = GetSystemMetrics(SM_CYHSCROLL)
'改变窗口宽度与高度
Width = Width + hsWidth
Height = Height + hsHeight
VVisible = True
HVisible = True

'滚动范围的设置
yMin = 0: yMax = 1000
xMin = 0: xMax = 1000
SetScrollRange hWnd, SB_HORZ, xMin, xMax, True
SetScrollRange hWnd, SB_VERT, yMin, yMax, True
'建立子类窗口
SubClass Me
End Sub

'滚动条的显示与隐藏
Private Sub Command1_Click()
If VVisible Then
Command1.Caption = “显示垂直滚动条”
ShowScrollBar hWnd, SB_VERT, False
VVisible = False
Else
Command1.Caption = “隐藏垂直滚动条”
ShowScrollBar hWnd, SB_VERT, True
VVisible = True
End If
End Sub

Private Sub Command2_Click()
If VVisible Then
Command2.Caption = “显示水平滚动条”
ShowScrollBar hWnd, SB_HORZ, False
VVisible = False
Else
Command2.Caption = “隐藏水平滚动条”
ShowScrollBar hWnd, SB_HORZ, True
VVisible = True
End If
End Sub

'子类窗口的撤消
Private Sub Form_Unload(Cancel As Integer)
UnSubClass Me
End Sub
'--------------------------------------------------------------------------------------------------
'Module1
Option Explicit

'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
Public Const SM_CYHSCROLL = 3 '水平滚动条的宽度
'以下以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)
End Sub

Public Sub UnSubClass(frm As Form)
Call SetWindowLong(frm.hWnd, GWL_WNDPROC, preWndProc)
End Sub

'下面的函数在API开发中非常有用。
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