vb利用类模块获得鼠标滚轮(滑轮)事件

'添加一个类模块，模块名称设置为：cSubclass
'代码如下：
Option Explicit
Private Declare Sub CopyMemory Lib “kernel32” Alias “RtlMoveMemory” (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
Private 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
Private Declare Function SetWindowLong Lib “user32” Alias “SetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib “user32” Alias “GetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function VirtualProtect Lib “kernel32” (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Type ThisClassSet
s_srcWndProcAddress As Long
s_Hwnd As Long
End Type
Const SWP_SHOWWINDOW = &H40
Const GWL_WNDPROC = (-4)
Dim PG As ThisClassSet
Dim LinkProc() As Long
'定义用户自定义的事件
Event GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)

Private Sub MsgHook(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
'子类化接口过程
RaiseEvent GetWindowMessage(Result, cHwnd, Message, wParam, lParam)
End Sub

Private Function GetWndProcAddress(ByVal SinceCount As Long) As Long
’ 地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性） =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
Dim mePtr As Long
Dim jmpAddress As Long
mePtr = ObjPtr(Me)
CopyMemory jmpAddress, ByVal mePtr, 4
CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4

ReDim LinkProc(10)
LinkProc(0) = &H83EC8B55
LinkProc(1) = &HFC8B14EC
LinkProc(2) = &H56FC758D
LinkProc(3) = &H3308758D
LinkProc(4) = &HFC04B1C9
LinkProc(5) = &HFF68A5F3
LinkProc(6) = &HB8FFFFFF
LinkProc(7) = &HFFFFFFFF
LinkProc(8) = &H48BD0FF
LinkProc(9) = &H10C2C924

CopyMemory ByVal VarPtr(LinkProc(5)) + 3, mePtr, 4
CopyMemory ByVal VarPtr(LinkProc(7)), jmpAddress, 4
GetWndProcAddress = VarPtr(LinkProc(0))
VirtualProtect ByVal VarPtr(LinkProc(0)), 44, SWP_SHOWWINDOW, mePtr

End Function

Function CallDefaultWindowProc(ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'调用窗口默认处理过程
CallDefaultWindowProc = CallWindowProc(PG.s_srcWndProcAddress, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
End Function

Function SetMsgHook(ByVal cHwnd As Long) As Long
'设置指定窗口的子类化
PG.s_Hwnd = cHwnd
PG.s_srcWndProcAddress = SetWindowLong(ByVal cHwnd, ByVal GWL_WNDPROC, ByVal GetWndProcAddress(4))
SetMsgHook = PG.s_srcWndProcAddress
End Function

Sub SetMsgUnHook()
'取消窗口子类化
SetWindowLong ByVal PG.s_Hwnd&, ByV
al GWL_WNDPROC, ByVal PG.s_srcWndProcAddress&
End Sub
’
’
’
'窗体(Form)调用
'代码如下：
Dim WithEvents oSubClass As cSubclass
Dim M As Long
Private Sub Form_Load()
Set oSubClass = New cSubclass’初始化对象
oSubClass.SetMsgHook Me.hWnd '开始子类化
End Sub

Private Sub Form_Unload(Cancel As Integer)
oSubClass.SetMsgUnHook '解除子类化
Set oSubClass = Nothing '销毁对象
End Sub

Private Sub oSubClass_GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
Select Case Message
Case WM_MOUSEWHEEL '鼠标滚轮
M = IIf(wParam < 0, IIf(M >= 100, 100, M + 1), IIf(M <= 0, 0, M - 1))
Text1.text=M
End Select
Result = oSubClass.CallDefaultWindowProc(cHwnd, Message, wParam, lParam)
End Sub

标签：LinkProc,vb,End,鼠标,ByVal,滚轮,Long,Private,Sub
来源： https://blog.csdn.net/ty5858/article/details/122260429