VB6/VBA中跟踪鼠标移出窗体控件事件(类模块成员函数指针CHooker类应用)
2016-09-21 10:56
357 查看
一、关于起因
前几天发了一篇博文,是关于获取VB类模块成员函数指针的内容(http://www.cnblogs.com/alexywt/p/5880993.html);今天我就发一下我的应用实例。
VB中默认是没有鼠标移出事件响应的,而这个事件其实在项目开发中,实用性很强,很多时候需要在鼠标移出窗体或控件时做些事情;没有这个事件会感觉很费力;
今天我所说的实际案例就是,在窗体上,设计一个SplitterBar控件,窗体的最终用户使用这个控件可以在运行程序时任意调整其内部控件大小。
二、修改CHooker类
我在第二篇参考博文作者开发的CHooker类上做了部分修改(对应以下代码中的中文注释部分代码),使该类能够跟踪鼠标移开事件,代码如下:
三、CHooker类的使用
那么如何使用这个新构建的类,来实现我们的需求了?首先创建一个窗体,放置三个PictureBox,其中一个做为SplitterBar(name属性picture4),其余2个图片框的宽度将会由SplitterBar在运行时调整。
四、其他说明
mdlCommon.TwipsPerPixelX()函数是在模块mdlCommon的一个公共函数,相关代码如下:
前几天发了一篇博文,是关于获取VB类模块成员函数指针的内容(http://www.cnblogs.com/alexywt/p/5880993.html);今天我就发一下我的应用实例。
VB中默认是没有鼠标移出事件响应的,而这个事件其实在项目开发中,实用性很强,很多时候需要在鼠标移出窗体或控件时做些事情;没有这个事件会感觉很费力;
今天我所说的实际案例就是,在窗体上,设计一个SplitterBar控件,窗体的最终用户使用这个控件可以在运行程序时任意调整其内部控件大小。
二、修改CHooker类
我在第二篇参考博文作者开发的CHooker类上做了部分修改(对应以下代码中的中文注释部分代码),使该类能够跟踪鼠标移开事件,代码如下:
Option Explicit Private Type TRACKMOUSEEVENTTYPE cbSize As Long dwFlags As Long hwndTrack As Long dwHoverTime As Long End Type Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 IsWindow Lib "user32" (ByVal hWnd As Long) As Long 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 TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long Private Const GWL_WNDPROC = (-4) Private Const WM_NCDESTROY = &H82 Private Const WM_MOUSEMOVE = &H200 Private Const TME_LEAVE = &H2& Private Const WM_MOUSELEAVE = &H2A3& Public Event WindowProc(ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCallNext As Boolean, lReturn As Long) Private m_hwnd As Long, m_NewProc As Long, m_OldProc As Long Private m_TrackMouseLeave As Boolean 'm_TrackMouseLeave设置在Hook时是否开启跟踪鼠标移开事件,是否正在跟踪移动事件 Private m_Tracking As Boolean '跟踪移开事件时,标识当前是否正在跟踪移动事件 Private Sub Class_Initialize() m_NewProc = GetClassProcAddr(Me, 5, 4, True) End Sub Private Sub Class_Terminate() Call Unbind End Sub Public Function Bind(ByVal hWnd As Long, Optional TrackMouseLeave As Boolean = False) As Boolean Call Unbind If IsWindow(hWnd) Then m_hwnd = hWnd m_OldProc = SetWindowLong(m_hwnd, GWL_WNDPROC, m_NewProc) Bind = CBool(m_OldProc) m_TrackMouseLeave = TrackMouseLeave '保存用户传递的跟踪鼠标移开事件设置 End Function Public Function Unbind() As Boolean If m_OldProc <> 0 Then Unbind = CBool(SetWindowLong(m_hwnd, GWL_WNDPROC, m_OldProc)) m_OldProc = 0 End Function Private Function WindowProcCallBack(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Dim bCallNext As Boolean, lReturn As Long Dim tTrackML As TRACKMOUSEEVENTTYPE '一个移开事件结构声明 bCallNext = True RaiseEvent WindowProc(Msg, wParam, lParam, bCallNext, lReturn) '当用户需要跟踪鼠标移开事件时 If m_TrackMouseLeave Then '鼠标在其上移动,当前未标识为跟踪状态(第一次或者移开鼠标后重新移动回来时) If Msg = WM_MOUSEMOVE And m_Tracking = False Then m_Tracking = True 'initialize structure tTrackML.cbSize = Len(tTrackML) tTrackML.hwndTrack = hWnd tTrackML.dwFlags = TME_LEAVE 'start the tracking TrackMouseEvent tTrackML End If '鼠标移开时,取消跟踪状态 If Msg = WM_MOUSELEAVE Then m_Tracking = False End If If bCallNext Then WindowProcCallBack = CallWindowProc(m_OldProc, hWnd, Msg, wParam, lParam) Else WindowProcCallBack = lReturn End If If hWnd = m_hwnd And Msg = WM_NCDESTROY Then Call Unbind End Function Private Function GetClassProcAddr(obj As Object, ByVal Index As Long, _ Optional ByVal ParamCount As Long = 4, Optional ByVal HasReturnValue As Boolean) As Long Static lReturn As Long, pReturn As Long Static AsmCode(50) As Byte Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long pThis = ObjPtr(obj) CopyMemory pVtbl, ByVal pThis, 4 CopyMemory pFunc, ByVal pVtbl + (6 + Index) * 4, 4 pReturn = VarPtr(lReturn) For i = 0 To UBound(AsmCode) '填充nop AsmCode(i) = &H90 Next AsmCode(0) = &H55 'push ebp AsmCode(1) = &H8B: AsmCode(2) = &HEC 'mov ebp,esp AsmCode(3) = &H53 'push ebx AsmCode(4) = &H56 'push esi AsmCode(5) = &H57 'push edi If HasReturnValue Then AsmCode(6) = &HB8 'mov offset lReturn CopyMemory AsmCode(7), pReturn, 4 AsmCode(11) = &H50 'push eax End If For i = 0 To ParamCount - 1 'push dword ptr[ebp+xx] AsmCode(12 + i * 3) = &HFF AsmCode(13 + i * 3) = &H75 AsmCode(14 + i * 3) = (ParamCount - i) * 4 + 4 Next i = i * 3 + 12 AsmCode(i) = &HB9 'mov ecx,this CopyMemory AsmCode(i + 1), pThis, 4 AsmCode(i + 5) = &H51 'push ecx AsmCode(i + 6) = &HE8 'call 相对地址 CopyMemory AsmCode(i + 7), pFunc - VarPtr(AsmCode(i + 6)) - 5, 4 If HasReturnValue Then AsmCode(i + 11) = &HB8 'mov eax,offset lReturn CopyMemory AsmCode(i + 12), pReturn, 4 AsmCode(i + 16) = &H8B 'mov eax,dword ptr[eax] AsmCode(i + 17) = &H0 End If AsmCode(i + 18) = &H5F 'pop edi AsmCode(i + 19) = &H5E 'pop esi AsmCode(i + 20) = &H5B 'pop ebx AsmCode(i + 21) = &H8B: AsmCode(i + 22) = &HE5 'mov esp,ebp AsmCode(i + 23) = &H5D 'pop ebp AsmCode(i + 24) = &HC3 'ret GetClassProcAddr = VarPtr(AsmCode(0)) End Function
三、CHooker类的使用
那么如何使用这个新构建的类,来实现我们的需求了?首先创建一个窗体,放置三个PictureBox,其中一个做为SplitterBar(name属性picture4),其余2个图片框的宽度将会由SplitterBar在运行时调整。
Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private mCanMove As Boolean Private mPreCursorPos As POINTAPI Private mCurCursorPos As POINTAPI Private WithEvents mHooker As CHooker Private Sub MDIForm_Load() Set mHooker = New CHooker call mHooker.Bind(Picture4.hWnd, True) End Sub Private Sub MDIForm_Unload(Cancel As Integer) mHooker.Unbind Set mHooker = Nothing End Sub Private Sub mHooker_WindowProc(ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCallNext As Boolean, lReturn As Long) If Msg = WM_MOUSELEAVE Then Me.MousePointer = 0 End Sub Private Sub picture4_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Call GetCursorPos(mPreCursorPos) End Sub Private Sub picture4_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Me.MousePointer = vbSizeWE If (Button And vbLeftButton) > 0 Then Call GetCursorPos(mCurCursorPos) mCanMove = True Picture4.Move Picture4.Left + (mCurCursorPos.x - mPreCursorPos.x) * mdlCommon.TwipsPerPixelX() mPreCursorPos = mCurCursorPos End If End Sub Private Sub picture4_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If mCanMove Then '此处添加调整界面元素位置与大小的代码 End If End Sub
四、其他说明
mdlCommon.TwipsPerPixelX()函数是在模块mdlCommon的一个公共函数,相关代码如下:
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long Private Const HWND_DESKTOP As Long = 0 Private Const LOGPIXELSX As Long = 88 Private Const LOGPIXELSY As Long = 90 'TwipsPerPixelX:屏幕水平方向上1像素转换为对应的缇值 Public Function TwipsPerPixelX() As Single Dim lngDC As Long lngDC = GetDC(HWND_DESKTOP) TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX) ReleaseDC HWND_DESKTOP, lngDC End Function 'TwipsPerPixelY:屏幕垂直方向上1像素转换为对应的缇值 Public Function TwipsPerPixelY() As Single Dim lngDC As Long lngDC = GetDC(HWND_DESKTOP) TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY) ReleaseDC HWND_DESKTOP, lngDC End Function
相关文章推荐
- WinForm 鼠标进入移开窗体事件,因子控件导致的误触发
- 扩展TImage控件,使其有鼠标移进移出的事件。
- c# 给窗体添加MouseEnter事件,可鼠标移到任意控件均会产生MouseEnter事件,如何识别是哪个产生的呢?
- 在WPF中强制捕获鼠标,鼠标移出控件后依然何以获取鼠标事件
- 窗体和控件的AutoScroll属性和鼠标的滚轮(MouseWheel)事件
- WPF,强制捕获鼠标事件,鼠标移出控件外依然可以执行强制捕获的鼠标事件
- WPF,强制捕获鼠标事件,鼠标移出控件外依然可以执行强制捕获的鼠标事件
- 鼠标移出窗体事件
- 在Event内部监测鼠标事件,对窗体内控件调用move动作,UI不刷新
- 窗体和控件的AutoScroll属性和鼠标的滚轮(MouseWheel)事件
- 关于窗体和控件获取与失去输入焦点的事件
- WebBrowser控件[Windows窗体]之应用篇
- VC窗体获取鼠标离开事件
- Asp.net 2.0 GridView的几个事件(如实现: 行的双击/单击/捕捉键盘按键/鼠标悬浮/移出效果)(示例代码下载)
- GridView的几个事件(如实现: 行的双击/单击/捕捉键盘按键/鼠标悬浮/移出效果)(示例代码下载)
- WebBrowser控件应用:弹出新窗体和关闭窗口
- 委托与事件的应用---翻页控件
- GridView的几个事件(如实现: 行的双击/单击/捕捉键盘按键/鼠标悬浮/移出效果)(示例代码下载)
- Asp.net 2.0 GridView的几个事件(如实现: 行的双击/单击/捕捉键盘按键/鼠标悬浮/移出效果)(转)
- (改进)UserControl的单击事件对鼠标左右键都有效,怎样使之像按钮控件那样只对鼠标左键敏感?