一、关于起因

前几天发了一篇博文,是关于获取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 = (-)
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, , , 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 <> Then Unbind = CBool(SetWindowLong(m_hwnd, GWL_WNDPROC, m_OldProc))
m_OldProc =
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 = , Optional ByVal HasReturnValue As Boolean) As Long
Static lReturn As Long, pReturn As Long
Static AsmCode() As Byte Dim i As Long, pThis As Long, pVtbl As Long, pFunc As Long pThis = ObjPtr(obj)
CopyMemory pVtbl, ByVal pThis,
CopyMemory pFunc, ByVal pVtbl + ( + Index) * ,
pReturn = VarPtr(lReturn)
For i = To UBound(AsmCode) '填充nop
AsmCode(i) = &H90
Next
AsmCode() = &H55 'push ebp
AsmCode() = &H8B: AsmCode() = &HEC 'mov ebp,esp
AsmCode() = &H53 'push ebx
AsmCode() = &H56 'push esi
AsmCode() = &H57 'push edi
If HasReturnValue Then
AsmCode() = &HB8 'mov offset lReturn
CopyMemory AsmCode(), pReturn,
AsmCode() = &H50 'push eax
End If
For i = To ParamCount - 'push dword ptr[ebp+xx]
AsmCode( + i * ) = &HFF
AsmCode( + i * ) = &H75
AsmCode( + i * ) = (ParamCount - i) * +
Next
i = i * +
AsmCode(i) = &HB9 'mov ecx,this
CopyMemory AsmCode(i + ), pThis,
AsmCode(i + ) = &H51 'push ecx
AsmCode(i + ) = &HE8 'call 相对地址
CopyMemory AsmCode(i + ), pFunc - VarPtr(AsmCode(i + )) - ,
If HasReturnValue Then
AsmCode(i + ) = &HB8 'mov eax,offset lReturn
CopyMemory AsmCode(i + ), pReturn,
AsmCode(i + ) = &H8B 'mov eax,dword ptr[eax]
AsmCode(i + ) = &H0
End If
AsmCode(i + ) = &H5F 'pop edi
AsmCode(i + ) = &H5E 'pop esi
AsmCode(i + ) = &H5B 'pop ebx
AsmCode(i + ) = &H8B: AsmCode(i + ) = &HE5 'mov esp,ebp
AsmCode(i + ) = &H5D 'pop ebp
AsmCode(i + ) = &HC3 'ret
GetClassProcAddr = VarPtr(AsmCode())
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 =
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) > 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 =
Private Const LOGPIXELSX As Long =
Private Const LOGPIXELSY As Long = 'TwipsPerPixelX:屏幕水平方向上1像素转换为对应的缇值
Public Function TwipsPerPixelX() As Single
Dim lngDC As Long lngDC = GetDC(HWND_DESKTOP)
TwipsPerPixelX = & / 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 = & / GetDeviceCaps(lngDC, LOGPIXELSY)
ReleaseDC HWND_DESKTOP, lngDC
End Function

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

  1. [转]C#鼠标拖动任意控件

    C#鼠标拖动任意控件(winform) 分类: c#2011-08-15 22:51 178人阅读 评论(0) 收藏 举报 winformc#userwindowsobjectapi using Sy ...

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

    引言 这两天沉迷了Google SketchUp,刚刚玩够,一时兴起,研究了一下WebBrowser. 我在<WebBrowser控件使用技巧分享>一文中曾谈到过“我现在可以通过WebBr ...

  3. ASP.NET中 WebForm 窗体控件使用及总结【转】

    原文链接:http://www.cnblogs.com/ylbtech/archive/2013/03/06/2944675.html ASP.NET中 WebForm 窗体控件使用及总结. 1.A, ...

  4. 如何在多线程中调用winform窗体控件

    由于 Windows 窗体控件本质上不是线程安全的.因此如果有两个或多个线程适度操作某一控件的状态(set value),则可能会迫使该控件进入一种不一致的状态.还可能出现其他与线程相关的 bug,包 ...

  5. c#中如何跨线程调用windows窗体控件

    c#中如何跨线程调用windows窗体控件?   我们在做winform应用的时候,大部分情况下都会碰到使用多线程控制界面上控件信息的问题.然而我们并不能用传统方法来做这个问题,下面我将详细的介绍.首 ...

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

    一.关于起因 最近在Office的QQ群里问如何在一串字符串中提取数值并加总的问题.如果使用正则表达式可以非常迅速的解决这个问题. 那么今天我就探讨一下在VB6/VBA中使用正则表达式的方法及代码,另 ...

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

    通过执行一段VBS代码来操控窗体内的控件也可以使用AddObject方法添加自己的类,那么在动态VBS代码中也一样可以使用在增加程序扩展性或是有脚本化需求的时候,这个方法还是不错的. Option E ...

  8. 【C#】DockPanelSuite 中 DockState.Document 状态下子窗体控件不显示的解决方案

    DockPanelSuite 是 Winform 中优秀的布局控件,但是这次使用过程中却出了个问题. 我遇到的问题是这样的,主窗体是通过 ShowDialog 显示的,子窗体的停靠状态为 DockSt ...

  9. c#中如何跨线程调用windows窗体控件?

    我们在做winform应用的时候,大部分情况下都会碰到使用多线程控制界面上控件信息的问题.然而我们并不能用传统方法来做这个问题,下面我将详细的介绍.首先来看传统方法: public partial c ...

随机推荐

  1. 一个Python小白5个小时爬虫经历

    前言 最近业余在做一个基于.NET Core的搜索项目,奈何基层代码写好了,没有看起来很华丽的数据供测试.很巧的也是博客搜索,于是乎想到了博客园.C#也能做做页面数据抓取的,不过在博客园看到的大部分都 ...

  2. 一期结业KTV项目难点

    查询完成后给歌曲便利到一个数组当中将选中的歌曲对象加入到playlist类中的数组songs. 创建类名称: class Playlist       {   //定义一个长度为50的数组       ...

  3. 零基础HTML编码学习笔记

    任务目的 了解HTML的定义.概念.发展简史 掌握常用HTML标签的含义.用法 能够基于设计稿来合理规划HTML文档结构 理解语义化,合理地使用HTML标签来构建页面 任务描述:完成一个HTML页面代 ...

  4. 谈 jquery中.band() .live() .delegate() .on()的区别

    bind(type,[data],fn) 为每个匹配元素的特定事件绑定事件处理函数 $("a").bind("click",function(){alert(& ...

  5. 【转】Jqgrid学习之ColModel API

    ColModel 是jqGrid里最重要的一个属性,设置表格列的属性. 属性 数据类型 备注 默认值 align string left, center, right. left classes st ...

  6. Selenium Web 自动化 - 项目持续集成(进阶)

    Selenium Web 自动化 - 项目持续集成(进阶) 2017-03-09 目录 1 背景及目标2 环境配置  2.1 SVN的安装及使用  2.2 新建Jenkins任务3 过程分析 1 背景 ...

  7. v3学院带您一起学习FPGA

    本文为原创,转载请注明! 课程名称:双buffer乒乓操作项目概况:使用FPGA内部ram作为缓冲器,实现对外部数据流的缓存:为了提升数据的传输及处理速度,在此节课中将用到两个ram进行乒乓操作.结构 ...

  8. Swashbuckle Swagger组件扩展

      用Swagger有一段时间, 我的model层是一个单独的dll 但给Swagger配置的是api层dll的XML. 所以就导致了model字段的注释不能够反应到参数说明. 所以我fork了一份 ...

  9. jenkins配置邮箱服务器(126邮箱)

    安装Email Extension Plugin 安装过程容易失败,多试几次 一.开启126邮件的SMTP获取授权码 二.配置管理员邮件地址   三.设置邮件通知 四.点击Test Configura ...

  10. struts.xml语法

    <!-- 1. struts.xml配置常量, 用来覆盖struts.properties中的默认常量配置 一般情况下, 这个配置放在struts.xml中, 不要放在各个模块的xml中. co ...