从以往子类化跟踪MouseLeave深入讨论VB6的自定义Hook类

Posted 2020-09-08

一、关于起因

之前发过一篇博文，是关于VB6中跟踪鼠标移出事件的示例(http://www.cnblogs.com/alexywt/p/5891827.html)

随着业务状况的不断发展,提出了更多的挑战和问题.

其一:子类化在VB6的IDE调试阶段会出现崩溃情况,需要实现子类化的无崩溃调试;

其一:我的窗体或自定义控件中可能有很多控件需要跟踪鼠标移出事件;甚至可能会通过代码来动态添加控件,要监听移出事件,通常是用WithEvents,但VB6的该关键字不支持数组对象的事件跟踪.也就是说要找到一种方式来批量处理大量控件的鼠标移出事件.

二、修改CHooker类使子类化在IDE调试时不崩溃

我对原来的Hooker类进行了改进,使其能适应调试模式,而不至于造成IDE崩溃：废话不多说,直接上修改过之后的类模块代码如下,其中关键部分在GetWndProcAddress过程中对LogMode分类进行处理,该过程的代码源自"嗷嗷叫的老马"http://www.cnblogs.com/pctgl/articles/1586841.html

  1 Option Explicit
  2 
  3 Private Const WM_MOUSELEAVE = &H2A3&
  4 Private Const WM_MOUSEMOVE = &H200
  5 Private Const TME_LEAVE = &H2&
  6 
  7 Private Type TRACKMOUSEEVENTTYPE
  8     cbSize As Long
  9     dwFlags As Long
 10     hwndTrack As Long
 11     dwHoverTime As Long
 12 End Type
 13 
 14 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, Optional ByVal Length As Long = 4)
 15 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
 16 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 17 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
 18 Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
 19 Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
 20 Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
 21 Private Declare Function GetProcessHeap Lib "kernel32" () As Long
 22 Private Declare Function HeapAlloc Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal dwBytes As Long) As Long
 23 Private Declare Function HeapFree Lib "kernel32" (ByVal hHeap As Long, ByVal dwFlags As Long, ByVal lpMem As Long) As Long
 24 Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
 25 
 26 Private Type ThisClassSet
 27     s_srcWndProcAddress     As Long
 28     s_Hwnd                  As Long
 29     s_BlockProtect          As Long
 30     n_heapAlloc             As Long
 31 End Type
 32 
 33 Private LinkProc()              As Long
 34 Private PG                      As ThisClassSet
 35 Private mMouseLeaveTracking     As Boolean
 36 Private mHookObject             As Object
 37 
 38 Public Event GetWindowMessage(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
 39 Public Event MouseLeave()
 40 
 41 Private Sub HookProc(Result As Long, ByVal cHwnd As Long, ByVal Message As Long, ByVal wParam As Long, ByVal lParam As Long)
 42     Dim tTrackML As TRACKMOUSEEVENTTYPE \'一个移开事件结构声明
 43     \'子类化接口过程
 44     RaiseEvent GetWindowMessage(Result, cHwnd, Message, wParam, lParam)
 45     Select Case Message
 46     Case WM_MOUSEMOVE
 47         If Not mMouseLeaveTracking Then
 48             mMouseLeaveTracking = True
 49             \'initialize structure
 50             tTrackML.cbSize = Len(tTrackML)
 51             tTrackML.hwndTrack = cHwnd
 52             tTrackML.dwFlags = TME_LEAVE
 53             \'start the tracking
 54             TrackMouseEvent tTrackML
 55         End If
 56     Case WM_MOUSELEAVE
 57         RaiseEvent MouseLeave
 58         mMouseLeaveTracking = False
 59     End Select
 60     Result = CallWindowProc(PG.s_srcWndProcAddress, ByVal cHwnd&, ByVal Message&, ByVal wParam&, ByVal lParam&)
 61 End Sub
 62 
 63 Private Function GetWndProcAddress(ByVal OrgWindowProc As Long, ByVal SinceCount As Long) As Long
 64 \'   地址指针 ＝ GetWndProcAddress( 取第 N 个公共函数（属性）  =或= 所有公共函数个数 + 第 N 个私有函数的函数地址）
 65     Dim mePtr As Long
 66     Dim jmpAddress As Long
 67     Dim i As Long
 68 
 69     mePtr = ObjPtr(Me)
 70     CopyMemory jmpAddress, ByVal mePtr, 4
 71     CopyMemory jmpAddress, ByVal jmpAddress + (SinceCount - 1) * 4 + &H1C, 4
 72 
 73     If App.LogMode = 0 Then
 74 
 75         ReDim LinkProc(15) As Long
 76         
 77         LinkProc(0) = &H83EC8B55
 78         LinkProc(1) = &H75FFFCC4
 79         LinkProc(2) = &H1075FF14
 80         LinkProc(3) = &HFF0C75FF
 81         LinkProc(4) = &HB90875
 82         LinkProc(5) = &HFF000010
 83         LinkProc(6) = &H1F883D1
 84         LinkProc(7) = &H4D8D1575
 85         LinkProc(8) = &H6851FC
 86         LinkProc(9) = &HB8000020
 87         LinkProc(10) = &H3000
 88         LinkProc(11) = &H458BD0FF
 89         LinkProc(12) = &HB807EBFC
 90         LinkProc(13) = &H4000
 91         LinkProc(14) = &HC2C9D0FF
 92         LinkProc(15) = &H10
 93         
 94         CopyMemory ByVal VarPtr(LinkProc(4)) + 3, GetProcAddress(GetModuleHandle("vba6.dll"), "EbMode"), 4&             \' Label Sign: 0100000
 95         CopyMemory ByVal VarPtr(LinkProc(8)) + 3, ObjPtr(Me), 4&             \' Label Sign: 0200000
 96         LinkProc(10) = jmpAddress                                               \' Label Sign: 0300000
 97         LinkProc(13) = PG.s_srcWndProcAddress                                                \' Label Sign: 0400000
 98 
 99         PG.n_heapAlloc = HeapAlloc(GetProcessHeap, &H8, 64&)
100         CopyMemory ByVal PG.n_heapAlloc, LinkProc(0), 64&
101         VirtualProtect ByVal PG.n_heapAlloc, ByVal 64&, ByVal &H40&, PG.s_BlockProtect
102         GetWndProcAddress = PG.n_heapAlloc
103 
104     Else
105         ReDim LinkProc(10)
106         LinkProc(0) = &H83EC8B55
107         LinkProc(1) = &H75FFFCC4
108         LinkProc(2) = &H1075FF14
109         LinkProc(3) = &HFF0C75FF
110         LinkProc(4) = &H458D0875
111         LinkProc(5) = &H6850FC
112         LinkProc(6) = &HB8000010
113         LinkProc(7) = &H2000
114         LinkProc(8) = &H458BD0FF
115         LinkProc(9) = &H10C2C9FC
116         
117         CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4&             \' Label Sign: 0100000
118         LinkProc(7) = jmpAddress                                               \' Label Sign: 0200000
119         VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect
120         GetWndProcAddress = VarPtr(LinkProc(0))
121 
122     End If
123     
124 End Function
125 
126 Public Function StartHook(HookObject As Object) As Long
127     Dim cHwnd As Long
128     Set mHookObject = HookObject
129     cHwnd = HookObject.hWnd
130     \'设置指定窗口的子类化
131     PG.s_Hwnd = cHwnd
132     PG.s_srcWndProcAddress = GetWindowLong(cHwnd, ByVal -4&)
133     SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(PG.s_srcWndProcAddress, 4)
134     StartHook = PG.s_srcWndProcAddress
135 End Function
136 
137 Public Property Get HookObject() As Object
138     Set HookObject = mHookObject
139 End Property
140 
141 Public Sub UnHook()
142     \'取消窗口子类化
143     SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_srcWndProcAddress&
144     Set mHookObject = Nothing
145 End Sub
146 
147 Private Sub Class_Terminate()
148     If PG.n_heapAlloc Then
149         UnHook
150         VirtualProtect ByVal PG.n_heapAlloc, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect
151         HeapFree GetProcessHeap, ByVal 0&, PG.n_heapAlloc
152         PG.n_heapAlloc = 0
153     End If
154 End Sub

三、实现批量跟踪一个窗体上多个控件的某事件

实现批量跟踪事件的思路是:在窗体上建立一个函数,来处理多个控件的指定事件

那么问题来了,我们子类化只能针对一个控件实施,假如我们直接在窗体上一个一个控件去子类化并写事件处理函数的话,也就背离了我的目的,因为这样的话有多少个控件就有很多个事件处理函数要写,我们的目的是只要一个函数来处理.

解决的方案是再建立一个包装器类,该类要完成2个事情,其一将需子类化的对象完成子类化,其二将调用的那个窗体中的事件处理函数与子类化关联,使之子类化回调函数即为该窗体中的自定义函数.

那么问题又来了,包装器类的第一个功能很容易实现,我们可以直接在该包装器类内实例化一个CHooker对象,然后调用其StartHook即可,那么要如何关联窗体中的自定义函数了?

因为该自定义函数在窗体中,是不可能通过AddressOf来取得其地址调用的,我们这里通过建立代理类实现

在VB.net中我们用代理用的很频繁,那么在VB6中要怎么做了?

首先我们建立一个接口类IMouseLeaveCallBack,代码如下

1 Public Sub MouseLeave(Hooker As CHooker)
2 
3 End Sub

然后在建立代理类CMouseLeaveDelegate,代码如下所示,其关键是在初始化类过程中传递一个类型为IMouseLeaveCallBack的对象进去,随后在mHooker的MouseLeave事件回调中执行该IMouseLeaveCallBack对象的MouseLeave方法,并将mHooker传递给它,以便实现IMouseLeaveCallBack接口的类通过mHooker的HookObject得到发生鼠标移出事件的控件是谁.

 1 Private WithEvents mHooker As CHooker
 2 Private mDelegate As IMouseLeaveCallBack
 3 
 4 Public Sub InitClass(HookedObject As Object, DelegateObject As IMouseLeaveCallBack)
 5     Set mHooker = New CHooker
 6     mHooker.StartHook HookedObject
 7     Set mDelegate = DelegateObject
 8 End Sub
 9 
10 Private Sub Class_Terminate()
11     If mHooker Is Nothing Then Exit Sub
12     mHooker.UnHook
13     Set mHooker = Nothing
14 End Sub
15 
16 Private Sub mHooker_MouseLeave()
17     mDelegate.MouseLeave mHooker
18 End Sub

三、在窗体中实现接口函数

通过前面的处理之后,我们就可以在窗体上实现IMouseLeaveCallBack接口,并写该接口MouseLeave过程的实现代码了.

我的示例很简单,目的是为窗体上的按钮及图片框设置鼠标移动时背景色及鼠标离开后的背景色

其中鼠标移动背景色我是一个一个控件处理,这种方式非常麻烦,如果你想一个函数搞定所有控件的鼠标移动事件,可以参考鼠标移出事件的处理方式.这里我就是用来对比批量处理与单个单个处理的应用效果.

建立一个窗体,在窗体上建立一个按钮,一个PictureBox,我就只用了2个控件,注意按钮的Style要设置成Graphical,否则设置背景色无效.

在窗体中输入如下所示代码,这里我通过一个数组保存所有需要进行Hook的控件,以便能通过一个For循环遍历实施Hook.

Implements IMouseLeaveCallBack

Private mHookedObjects(1 To 2) As Object
Private mMouseLeaveHandles(1 To 2) As CMouseLeaveDelegate

Private Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Command1.BackColor = RGB(255, 0, 0)
End Sub

Private Sub Form_Load()
    Set mHookedObjects(1) = Me.Command1
    Set mHookedObjects(2) = Me.Picture1
    For i = 1 To 2
        Set mMouseLeaveHandles(i) = New CMouseLeaveDelegate
        mMouseLeaveHandles(i).InitClass mHookedObjects(i), Me
    Next
End Sub

Private Sub IMouseLeaveCallBack_MouseLeave(Hooker As CHooker)
    Hooker.HookObject.BackColor = RGB(255, 255, 0)
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Picture1.BackColor = RGB(255, 0, 0)
End Sub