首页 > 代码库 > VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)
VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)
前几天发了一篇博文，是关于获取VB类模块成员函数指针的内容(http://www.cnblogs.com/alexywt/p/5880993.html)；今天我就发一下我的应用实例。
VB中默认是没有鼠标移出事件响应的，而这个事件其实在项目开发中，实用性很强，很多时候需要在鼠标移出窗体或控件时做些事情；没有这个事件会感觉很费力；
今天我所说的实际案例就是，在窗体上，设计一个SplitterBar控件，窗体的最终用户使用这个控件可以在运行程序时任意调整其内部控件大小。
我在第二篇参考博文作者开发的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 edi100 If HasReturnValue Then101 AsmCode(6) = &HB8 ‘mov offset lReturn102 CopyMemory AsmCode(7), pReturn, 4103 AsmCode(11) = &H50 ‘push eax104 End If105 For i = 0 To ParamCount - 1 ‘push dword ptr[ebp+xx]106 AsmCode(12 + i * 3) = &HFF107 AsmCode(13 + i * 3) = &H75108 AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4109 Next110 i = i * 3 + 12111 AsmCode(i) = &HB9 ‘mov ecx,this112 CopyMemory AsmCode(i + 1), pThis, 4113 AsmCode(i + 5) = &H51 ‘push ecx114 AsmCode(i + 6) = &HE8 ‘call 相对地址115 CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4116 If HasReturnValue Then117 AsmCode(i + 11) = &HB8 ‘mov eax,offset lReturn118 CopyMemory AsmCode(i + 12), pReturn, 4119 AsmCode(i + 16) = &H8B ‘mov eax,dword ptr[eax]120 AsmCode(i + 17) = &H0121 End If122 AsmCode(i + 18) = &H5F ‘pop edi123 AsmCode(i + 19) = &H5E ‘pop esi124 AsmCode(i + 20) = &H5B ‘pop ebx125 AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5 ‘mov esp,ebp126 AsmCode(i + 23) = &H5D ‘pop ebp127 AsmCode(i + 24) = &HC3 ‘ret128 GetClassProcAddr = VarPtr(AsmCode(0))129 End Function
那么如何使用这个新构建的类，来实现我们的需求了？首先创建一个窗体，放置三个PictureBox，其中一个做为SplitterBar(name属性picture4)，其余2个图片框的宽度将会由SplitterBar在运行时调整。
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 POINTAPI10 Private mCurCursorPos As POINTAPI11 Private WithEvents mHooker As CHooker12 13 Private Sub MDIForm_Load()14 Set mHooker = New CHooker15 call mHooker.Bind(Picture4.hWnd, True)16 End Sub17 18 Private Sub MDIForm_Unload(Cancel As Integer)19 mHooker.Unbind20 Set mHooker = Nothing21 End Sub22 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 = 025 End Sub26 27 28 Private Sub picture4_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)29 Call GetCursorPos(mPreCursorPos)30 End Sub31 32 Private Sub picture4_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)33 Me.MousePointer = vbSizeWE34 If (Button And vbLeftButton) > 0 Then35 Call GetCursorPos(mCurCursorPos)36 mCanMove = True37 Picture4.Move Picture4.Left + (mCurCursorPos.x - mPreCursorPos.x) * mdlCommon.TwipsPerPixelX()38 mPreCursorPos = mCurCursorPos39 End If40 End Sub41 42 Private Sub picture4_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)43 If mCanMove Then44 ‘此处添加调整界面元素位置与大小的代码45 End If46 End Sub
mdlCommon.TwipsPerPixelX()函数是在模块mdlCommon的一个公共函数，相关代码如下：
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 Single12 Dim lngDC As Long13 14 lngDC = GetDC(HWND_DESKTOP)15 TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)16 ReleaseDC HWND_DESKTOP, lngDC17 End Function18 19 ‘TwipsPerPixelY：屏幕垂直方向上1像素转换为对应的缇值20 Public Function TwipsPerPixelY() As Single21 Dim lngDC As Long22 23 lngDC = GetDC(HWND_DESKTOP)24 TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)25 ReleaseDC HWND_DESKTOP, lngDC26 End Function
VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)
声明：以上内容来自用户投稿及互联网公开渠道收集整理发布，本网站不拥有所有权，未作人工编辑处理，也不承担相关法律责任，若内容有误或涉及侵权可进行投诉： 投诉/举报 工作人员会在5个工作日内联系你，一经查实，本站将立刻删除涉嫌侵权内容。