VB6给控件增加一个滚动事件

日期：2019年12月12日
作者：Commas
注释：VB6的控件本身是不支持鼠标滚轮滚动的事件，以前写的代码有点low，参考了一个大神的代码，重新写了一个类模块用来支持滚动事件，记录一下……
【资源下载】

---

---

一、效果

1. 窗体上放一个text控件，命名为txtNum
   
2. txtNum响应鼠标滚轮滚动，我做了一个前滚+1，后滚-1的操作，显示在txtNum.text里面。想要实现什么效果，自行更改txtNum_MouseWheel()子过程（写成了和事件一样的格式，目的很简单，为了统一风格）。
   （i）鼠标滚轮向前滚动示意图
   变化范围：-2→2
   
   （ii）鼠标滚轮向后滚动示意图
   变化范围：2→-2
   

二、原理

本质：
1、Hook消息处理函数
2、自己处理想要处理的消息（自定义的消息），比如做一个“鼠标滚轮的滚动事件”

三、代码

1. Demo窗体代码

Option Explicit

Private Sub Form_Load()
On Error Resume Next
    Call BindMyWndProc(Me)
End Sub

2. 类模块代码

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