VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)

  1 Option Explicit
  2 
  3 Private Type TRACKMOUSEEVENTTYPE
  4     cbSize As Long
  5     dwFlags As Long
  6     hwndTrack As Long
  7     dwHoverTime As Long
  8 End Type
  9 
 10 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
 11 Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 12 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
 13 Private Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
 14 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
 15 Private Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long
 16 
 17 Private Const GWL_WNDPROC = (-4)
 18 Private Const WM_NCDESTROY = &H82
 19 Private Const WM_MOUSEMOVE = &H200
 20 Private Const TME_LEAVE = &H2&
 21 Private Const WM_MOUSELEAVE = &H2A3&
 22 
 23 Public Event WindowProc(ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCallNext As Boolean, lReturn As Long)
 24 
 25 Private m_hwnd As Long, m_NewProc As Long, m_OldProc As Long
 26 Private m_TrackMouseLeave As Boolean        ‘m_TrackMouseLeave设置在Hook时是否开启跟踪鼠标移开事件，是否正在跟踪移动事件
 27 Private m_Tracking As Boolean               ‘跟踪移开事件时，标识当前是否正在跟踪移动事件
 28 
 29 Private Sub Class_Initialize()
 30     m_NewProc = GetClassProcAddr(Me, 5, 4, True)
 31 End Sub
 32 
 33 Private Sub Class_Terminate()
 34     Call Unbind
 35 End Sub
 36 
 37 Public Function Bind(ByVal hWnd As Long, Optional TrackMouseLeave As Boolean = False) As Boolean
 38     Call Unbind
 39     If IsWindow(hWnd) Then m_hwnd = hWnd
 40     m_OldProc = SetWindowLong(m_hwnd, GWL_WNDPROC, m_NewProc)
 41     Bind = CBool(m_OldProc)
 42     m_TrackMouseLeave = TrackMouseLeave ‘保存用户传递的跟踪鼠标移开事件设置
 43 End Function
 44 
 45 Public Function Unbind() As Boolean
 46     If m_OldProc <> 0 Then Unbind = CBool(SetWindowLong(m_hwnd, GWL_WNDPROC, m_OldProc))
 47     m_OldProc = 0
 48 End Function
 49 
 50 Private Function WindowProcCallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
 51     Dim bCallNext As Boolean, lReturn As Long
 52     Dim tTrackML As TRACKMOUSEEVENTTYPE ‘一个移开事件结构声明
 53     
 54     bCallNext = True
 55     
 56     RaiseEvent WindowProc(Msg, wParam, lParam, bCallNext, lReturn)
 57     ‘当用户需要跟踪鼠标移开事件时
 58     If m_TrackMouseLeave Then
 59         ‘鼠标在其上移动，当前未标识为跟踪状态(第一次或者移开鼠标后重新移动回来时)
 60         If Msg = WM_MOUSEMOVE And m_Tracking = False Then
 61             m_Tracking = True
 62             ‘initialize structure
 63             tTrackML.cbSize = Len(tTrackML)
 64             tTrackML.hwndTrack = hWnd
 65             tTrackML.dwFlags = TME_LEAVE
 66             ‘start the tracking
 67             TrackMouseEvent tTrackML
 68         End If
 69         ‘鼠标移开时，取消跟踪状态
 70         If Msg = WM_MOUSELEAVE Then m_Tracking = False
 71     End If
 72     
 73     If bCallNext Then
 74         WindowProcCallBack = CallWindowProc(m_OldProc, hWnd, Msg, wParam, lParam)
 75     Else
 76         WindowProcCallBack = lReturn
 77     End If
 78     If hWnd = m_hwnd And Msg = WM_NCDESTROY Then Call Unbind
 79 End Function
 80 
 81 Private Function GetClassProcAddr(obj As Object, ByVal Index As Long, _
 82    Optional ByVal ParamCount As Long = 4, Optional ByVal HasReturnValue As Boolean) As Long
 83     Static lReturn As Long, pReturn As Long
 84     Static AsmCode(50) As Byte
 85 
 86     Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long
 87 
 88     pThis = ObjPtr(obj)
 89     CopyMemory pVtbl, ByVal pThis, 4
 90     CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4
 91     pReturn = VarPtr(lReturn)
 92     For i = 0 To UBound(AsmCode)                                ‘填充nop
 93         AsmCode(i) = &H90
 94     Next
 95     AsmCode(0) = &H55                                           ‘push   ebp
 96     AsmCode(1) = &H8B: AsmCode(2) = &HEC                        ‘mov    ebp,esp
 97     AsmCode(3) = &H53                                           ‘push   ebx
 98     AsmCode(4) = &H56                                           ‘push   esi
 99     AsmCode(5) = &H57                                           ‘push   edi
100     If HasReturnValue Then
101         AsmCode(6) = &HB8                                       ‘mov    offset lReturn
102         CopyMemory AsmCode(7), pReturn, 4
103         AsmCode(11) = &H50                                      ‘push   eax
104     End If
105     For i = 0 To ParamCount - 1                                 ‘push   dword ptr[ebp+xx]
106         AsmCode(12 + i * 3) = &HFF
107         AsmCode(13 + i * 3) = &H75
108         AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4
109     Next
110     i = i * 3 + 12
111     AsmCode(i) = &HB9                                           ‘mov    ecx,this
112     CopyMemory AsmCode(i + 1), pThis, 4
113     AsmCode(i + 5) = &H51                                       ‘push ecx
114     AsmCode(i + 6) = &HE8                                       ‘call 相对地址
115     CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4
116     If HasReturnValue Then
117         AsmCode(i + 11) = &HB8                                  ‘mov    eax,offset lReturn
118         CopyMemory AsmCode(i + 12), pReturn, 4
119         AsmCode(i + 16) = &H8B                                  ‘mov    eax,dword ptr[eax]
120         AsmCode(i + 17) = &H0
121     End If
122     AsmCode(i + 18) = &H5F                                      ‘pop    edi
123     AsmCode(i + 19) = &H5E                                      ‘pop    esi
124     AsmCode(i + 20) = &H5B                                      ‘pop    ebx
125     AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5              ‘mov    esp,ebp
126     AsmCode(i + 23) = &H5D                                      ‘pop    ebp
127     AsmCode(i + 24) = &HC3                                      ‘ret
128     GetClassProcAddr = VarPtr(AsmCode(0))
129 End Function

 1 Private Type POINTAPI
 2     x As Long
 3     y As Long
 4 End Type
 5 
 6 Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 7 
 8 Private mCanMove      As Boolean
 9 Private mPreCursorPos As POINTAPI
10 Private mCurCursorPos As POINTAPI
11 Private WithEvents mHooker As CHooker
12 
13 Private Sub MDIForm_Load()
14     Set mHooker = New CHooker
15     call mHooker.Bind(Picture4.hWnd, True)
16 End Sub
17 
18 Private Sub MDIForm_Unload(Cancel As Integer)
19     mHooker.Unbind
20     Set mHooker = Nothing
21 End Sub
22 
23 Private Sub mHooker_WindowProc(ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCallNext As Boolean, lReturn As Long)
24     If Msg = WM_MOUSELEAVE Then Me.MousePointer = 0
25 End Sub
26 
27 
28 Private Sub picture4_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
29     Call GetCursorPos(mPreCursorPos)
30 End Sub
31 
32 Private Sub picture4_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
33     Me.MousePointer = vbSizeWE
34     If (Button And vbLeftButton) > 0 Then
35         Call GetCursorPos(mCurCursorPos)
36         mCanMove = True
37         Picture4.Move Picture4.Left + (mCurCursorPos.x - mPreCursorPos.x) * mdlCommon.TwipsPerPixelX()
38         mPreCursorPos = mCurCursorPos
39     End If
40 End Sub
41 
42 Private Sub picture4_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
43     If mCanMove Then
44         ‘此处添加调整界面元素位置与大小的代码
45     End If
46 End Sub

 1 Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
 2 Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
 3 Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
 4 
 5 
 6 Private Const HWND_DESKTOP As Long = 0
 7 Private Const LOGPIXELSX   As Long = 88
 8 Private Const LOGPIXELSY   As Long = 90
 9 
10 ‘TwipsPerPixelX：屏幕水平方向上1像素转换为对应的缇值
11 Public Function TwipsPerPixelX() As Single
12     Dim lngDC As Long
13 
14     lngDC = GetDC(HWND_DESKTOP)
15     TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
16     ReleaseDC HWND_DESKTOP, lngDC
17 End Function
18 
19 ‘TwipsPerPixelY：屏幕垂直方向上1像素转换为对应的缇值
20 Public Function TwipsPerPixelY() As Single
21     Dim lngDC As Long
22 
23     lngDC = GetDC(HWND_DESKTOP)
24     TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
25     ReleaseDC HWND_DESKTOP, lngDC
26 End Function