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   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

那么如何使用这个新构建的类，来实现我们的需求了？首先创建一个窗体，放置三个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 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

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 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

时间： 2024-10-10 22:02:44

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

VB6.0中，日期、时间控件不允许为空时，采用文本框与日期、时间控件相互替换赋值（解决方案）

VB6.0中,日期.时间控件不允许为空时,采用文本框与日期.时间控件相互替换赋值,或许是一个不错的选择. 实现效果如下图: 代码如下: 文本框txtStopTime1 时间框DTStopTime1 格式3 - dtpCustom HH:mm:ss Private Sub Form_Load() txtStopTime1.ZOrder DTStopTime1.Top = txtStopTime1.Top DTStopTime1.Left = txtStopTi

在线程中使用委托进行窗体控件赋值

若对窗体控件label进行赋值 delegate void SetLabelText(int str);//定义委托,用来完成线程的赋值 /// <summary> /// 为label赋值 /// </summary> /// <param name="str"></param> private void setLabel(int str) { this.lbCountY.Text = Convert.ToInt32( str).ToS

C#编写第三方控件，实现窗体控件的一键取值

上篇博客中讲到了利用编写第三方控件的方法,实现给窗体控件的Text属性赋值,比如说:TextBox,Combox等.有赋值,当然也有取值操作.从窗体的控件中取值,然后存入变量或者实体属性当中,传入到数据访问层进行添加,更新等操作也是我们经常使用的.如何实现一键取值呢? 使用的方法在上篇博客中已经做了详细说明,这里就不再累述了. 代码写在这里: 该方法的作用是,遍历传入窗体中的控件,并且获取其值赋给实体类的相应属性. /// <summary> /// 从窗体控件取值,填充到学生实体类中 ///

在WebBrowser中通过模拟键盘鼠标操控网页中的文件上传控件

在WebBrowser中通过模拟键盘鼠标操控网页中的文件上传控件引言这两天沉迷了Google SketchUp,刚刚玩够,一时兴起,研究了一下WebBrowser. 我在<WebBrowser控件使用技巧分享>一文中曾谈到过"我现在可以通过WebBrowser实现对各种Html元素的操控,唯独无法控制Html的上传控件",出于安全原因,IE没有对上传控件提供操控支持,这使得我们没法像控制其他控件一样用简单的代码进行赋值. 比较实际的解决方案就是模拟操作了,下面我就将演示

在VB中动态执行VBS代码,可操控窗体控件

通过执行一段VBS代码来操控窗体内的控件也可以使用AddObject方法添加自己的类,那么在动态VBS代码中也一样可以使用在增加程序扩展性或是有脚本化需求的时候,这个方法还是不错的. Option Explicit Dim vbs As Object Private Sub Command1_Click() vbs.ExecuteStatement "showtime" End Sub Private Sub Form_Load() Set vbs = CreateObject(&

在VB6/VBA中使用正则表达式

一.关于起因最近在Office的QQ群里问如何在一串字符串中提取数值并加总的问题.如果使用正则表达式可以非常迅速的解决这个问题. 那么今天我就探讨一下在VB6/VBA中使用正则表达式的方法及代码,另外为了快速测试正则表达式,我给大家推荐notepad++及使用方式. 二.操作步骤 1.按Alt+F11进入Excel的VBE环境,依次选择“工具/引用”菜单,选择“Microsoft VBScript Regular Express”: 2.插入一个模块,在模块中输入如下所示的代码: 1 Func

c#中如何跨线程调用windows窗体控件？(from www.sysoft.cc)

我们在做winform应用的时候,大部分情况下都会碰到使用多线程控制界面上控件信息的问题.然而我们并不能用传统方法来做这个问题首先来看传统方法: public partial class Form1 : Form { public Form1() { InitializeComponent(); } private void Form1_Load(object sender, EventArgs e) { Thread thread = new Thread(ThreadFuntion); t

C#窗体控件简介ListBox

ListBox 控件ListBox 控件又称列表框,它显示一个项目列表供用户选择.在列表框中,用户一次可以选择一项,也可以选择多项.1.常用属性:(1) Items属性: 用于存放列表框中的列表项,是一个集合.通过该属性,可以添加列表项.移除列表项和获得列表项的数目.(2)MultiColumn 属性:用来获取或设置一个值,该值指示ListBox是否支持多列.值为 true 时表示支持多列,值为 false 时不支持多列.当使用多列模式时,可以使控件得以显示更多可见项.(3)ColumnWidt

(转)sl简单自定义win窗体控件

sl简单自定义win窗体控件相信大家接触过不少win窗体控件ChildWin子窗口就的sl自带的一个而且网上也有很多类似的控件,而今天我和大家分享下自己制作个win窗体控件,希望对初学sl的朋友在学习自定义控件时有帮助. 首先先明确下两个概念用户控件和模板化控件. 用户控件是继承UserControl而来的控件,由于UserControl不支持模板,所以它只能用于组合现有控件件而不能用于设计可定制外观的控件. 模板化控件是继承自ContentControl, Control等支持模板的而来的