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_BlockProtect102         GetWndProcAddress = PG.n_heapAlloc103 104     Else105         ReDim LinkProc(10)106         LinkProc(0) = &H83EC8B55107         LinkProc(1) = &H75FFFCC4108         LinkProc(2) = &H1075FF14109         LinkProc(3) = &HFF0C75FF110         LinkProc(4) = &H458D0875111         LinkProc(5) = &H6850FC112         LinkProc(6) = &HB8000010113         LinkProc(7) = &H2000114         LinkProc(8) = &H458BD0FF115         LinkProc(9) = &H10C2C9FC116         117         CopyMemory ByVal VarPtr(LinkProc(5)) + 3, ObjPtr(Me), 4&             ‘ Label Sign: 0100000118         LinkProc(7) = jmpAddress                                               ‘ Label Sign: 0200000119         VirtualProtect ByVal VarPtr(LinkProc(0)), ByVal 40&, ByVal &H40&, PG.s_BlockProtect120         GetWndProcAddress = VarPtr(LinkProc(0))121 122     End If123     124 End Function125 126 Public Function StartHook(HookObject As Object) As Long127     Dim cHwnd As Long128     Set mHookObject = HookObject129     cHwnd = HookObject.hWnd130     ‘设置指定窗口的子类化131     PG.s_Hwnd = cHwnd132     PG.s_srcWndProcAddress = GetWindowLong(cHwnd, ByVal -4&)133     SetWindowLong ByVal cHwnd, ByVal -4&, ByVal GetWndProcAddress(PG.s_srcWndProcAddress, 4)134     StartHook = PG.s_srcWndProcAddress135 End Function136 137 Public Property Get HookObject() As Object138     Set HookObject = mHookObject139 End Property140 141 Public Sub UnHook()142     ‘取消窗口子类化143     SetWindowLong ByVal PG.s_Hwnd&, ByVal -4&, ByVal PG.s_srcWndProcAddress&144     Set mHookObject = Nothing145 End Sub146 147 Private Sub Class_Terminate()148     If PG.n_heapAlloc Then149         UnHook150         VirtualProtect ByVal PG.n_heapAlloc, ByVal 64&, ByVal PG.s_BlockProtect, PG.s_BlockProtect151         HeapFree GetProcessHeap, ByVal 0&, PG.n_heapAlloc152         PG.n_heapAlloc = 0153     End If154 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 Sub12     mHooker.UnHook13     Set mHooker = Nothing14 End Sub15 16 Private Sub mHooker_MouseLeave()17     mDelegate.MouseLeave mHooker18 End Sub

Implements IMouseLeaveCallBackPrivate mHookedObjects(1 To 2) As ObjectPrivate mMouseLeaveHandles(1 To 2) As CMouseLeaveDelegatePrivate Sub Command1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)    Command1.BackColor = RGB(255, 0, 0)End SubPrivate 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    NextEnd SubPrivate Sub IMouseLeaveCallBack_MouseLeave(Hooker As CHooker)    Hooker.HookObject.BackColor = RGB(255, 255, 0)End SubPrivate Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)    Picture1.BackColor = RGB(255, 0, 0)End Sub