日期:2019年12月12日
作者:Commas
注释:VB6的控件本身是不支持鼠标滚轮滚动的事件,以前写的代码有点low,参考了一个大神的代码,重新写了一个类模块用来支持滚动事件,记录一下……
【资源下载】
一、效果
- 窗体上放一个
text控件
,命名为txtNum
txtNum
响应鼠标滚轮滚动,我做了一个前滚+1,后滚-1的操作,显示在txtNum.text里面。想要实现什么效果,自行更改txtNum_MouseWheel()子过程(写成了和事件一样的格式,目的很简单,为了统一风格)。
(i)鼠标滚轮向前滚动示意图
变化范围:-2→2
(ii)鼠标滚轮向后滚动示意图
变化范围:2→-2
二、原理
本质:
1、Hook消息处理函数
2、自己处理想要处理的消息(自定义的消息),比如做一个“鼠标滚轮的滚动事件”
三、代码
- Demo窗体代码
Option Explicit
Private Sub Form_Load()
On Error Resume Next
Call BindMyWndProc(Me)
End Sub
- 类模块代码
Option Explicit
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) 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 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 Const GWL_WNDPROC = (-4)
Private Const WM_MOUSEWHEEL As Long = &H20A& ' 滚轮事件的消息
Private Const WHEEL_DELTA = 120
'需要增加滚轮事件的控件相关变量
Private txtNum_hWnd As Long 'txtNum的hWnd值
Private txtNum_OldWndProc As Long 'txtNum的旧消息处理函数的地址
Private oContainer As Object
'初始化操作(绑定容器对象,指定接收消息的对象),控件才能识别鼠标滚轮。
Public Sub BindMyWndProc(ByRef objContainer As Object)
On Error Resume Next
Set oContainer = objContainer'设置容器窗体
'(1)txtNum
txtNum_hWnd = oContainer.txtNum.hWnd
txtNum_OldWndProc = GetWindowLong(txtNum_hWnd, GWL_WNDPROC) '取得原先的消息处理函数的入口
SetWindowLong txtNum_hWnd, GWL_WNDPROC, AddressOf registerWindowMessage '接收自定义消息处理函数
'(2)其它控件
End Sub
'自定义消息处理函数
Private Function registerWindowMessage(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
If Msg = WM_MOUSEWHEEL Then '(1)滚轮消息
Dim lngDelta As Long, lngButton As Long, lngX As Long, lngY As Long
lngButton = wParam And &HFFFF&
lngDelta = wParam \ &H10000
lngX = lParam And &HFFFF&
lngY = lParam \ &H10000
'(1-1)txtNum控件的消息
If hWnd = txtNum_hWnd Then Call txtNum_MouseWheel(lngDelta, lngButton, lngX, lngY)
'(1-2)其它控件的消息,若有则继续
Else '(2)其它消息:原路走xxx_OldWndProc
'(2-1)txtNum控件的消息
If hWnd = txtNum_hWnd Then registerWindowMessage = CallWindowProc(txtNum_OldWndProc, hWnd, Msg, wParam, lParam)
''' '(2-2)其它控件的消息,若有则继续
End If
End Function
'需要实现的“txtNum滚轮事件”
Private Sub txtNum_MouseWheel(ByVal Delta As Long, ByVal Button As Long, ByVal X As Long, ByVal Y As Long)
On Error Resume Next
Delta = Delta / WHEEL_DELTA
With oContainer.txtNum
.Text = Val(.Text) + Delta
.SelStart = 0
.SelLength = Len(.Text)
End With
End Sub
本文参考:https://www.0xaa55.com/thread-1635-1-1.html
版权声明:本文为博主原创文章,如需转载,请给出:
原文链接:https://blog.csdn.net/qq_35844043/article/details/103514150