0xAA55 发表于 2016-6-25 06:53:00

【VB6】鼠标滚轮支持模块

用法：调用EnableMouseWheel使特定控件支持滚轮消息。滚轮消息发生后，Ctrl.OnMouseWheelCallBack会被调用。
OnMouseWheelCallBack的参数列表必须是(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
你可以在一个Form窗体里写这个过程，就像这样：Sub OnMouseWheelCallBack(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
If hWnd = 某控件.hWnd Then '判断是哪个控件发生了鼠标滚轮事件
    '处理滚轮消息
    'Delta是滚动值，通常为 120 或者 -120
    'X和Y是鼠标滚轮被搓动的时候，鼠标指针的坐标（相对于控件左上角）
End If
End Sub以下是这个模块的源码。顺带我想知道，我是把Ctrl定义为Object，并且调用了它的OnMouseWheelCallBack。不是所有的Object都有OnMouseWheelCallBack方法的，VB6是在编译的时候确定OnMouseWheelCallBack的地址还是在运行的时候确定OnMouseWheelCallBack的地址？求解答……Option Explicit

Private Type CtrlWndProcData_t
    Ctrl As Object '被调用OnMouseWheelCallBack的对象
    hWnd As Long
    OldWndProc As Long '旧消息函数
End Type

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 = &H20A

Private m_Ctrls() As CtrlWndProcData_t
Private m_NbCtrls As Long
Private m_MaxCtrls As Long
Private Const m_NbCtrlsAlloc As Long = 8

'启用特定控件、窗体对鼠标滚轮事件的支持
'调用后，如果发生了鼠标滚轮事件，Ctrl.OnMouseWheelCallBack会被调用。
'OnMouseWheelCallBack的参数列表必须是(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
Sub EnableMouseWheel(Ctrl As Object, ByVal hWnd As Long)
Dim OldWndProc As Long
OldWndProc = GetWindowLong(hWnd, GWL_WNDPROC)
If OldWndProc = 0 Then Exit Sub

'“注册”hWnd的值到数组里
If m_NbCtrls >= m_MaxCtrls Then
    If m_MaxCtrls Then
      m_MaxCtrls = m_MaxCtrls + m_NbCtrlsAlloc
      ReDim Preserve m_Ctrls(m_MaxCtrls - 1)
    Else
      m_MaxCtrls = m_NbCtrlsAlloc
      ReDim m_Ctrls(m_MaxCtrls - 1)
    End If
End If

With m_Ctrls(m_NbCtrls)
    Set .Ctrl = Ctrl
    .hWnd = hWnd
    .OldWndProc = OldWndProc
End With
m_NbCtrls = m_NbCtrls + 1

'Hook消息处理函数
SetWindowLong hWnd, GWL_WNDPROC, AddressOf ProcMouseWheel
End Sub

'控件、窗体被销毁前需要调用这个函数恢复旧的消息函数值
Sub DisableMouseWheel(ByVal hWnd As Long)
Dim I&
For I = 0 To m_NbCtrls - 1
    If m_Ctrls(I).hWnd = hWnd Then
      If m_Ctrls(I).OldWndProc Then SetWindowLong hWnd, GWL_WNDPROC, m_Ctrls(I).OldWndProc
      m_NbCtrls = m_NbCtrls - 1
      m_Ctrls(I) = m_Ctrls(m_NbCtrls)
      m_MaxCtrls = m_NbCtrls
      If m_MaxCtrls Then ReDim Preserve m_Ctrls(m_MaxCtrls - 1) Else Erase m_Ctrls
    End If
Next
End Sub

'窗口消息处理函数
Private Function ProcMouseWheel(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
Dim I&
For I = 0 To m_NbCtrls - 1 '从“注册”了的hWnd里面找匹配的
    If m_Ctrls(I).hWnd = hWnd Then
      If Msg = WM_MOUSEWHEEL Then
            '找到后就调用OnMouseWheelCallBack方法
            m_Ctrls(I).Ctrl.OnMouseWheelCallBack hWnd, (wp And &HFFFF0000) \ &H10000, lp And &HFFFF&, (lp And &HFFFF0000) \ &H10000
      End If
      '用原有的消息处理函数去处理剩下的消息
      ProcMouseWheel = CallWindowProc(m_Ctrls(I).OldWndProc, hWnd, Msg, wp, lp)
    End If
Next
End Function

乘简 发表于 2017-12-23 11:12:56

本帖最后由 乘简 于 2017-12-25 16:08 编辑

支持啊。。。

Tao0Lu 发表于 2018-3-3 19:54:04

做系统用的吧

大宝 发表于 2020-7-8 10:22:11

本帖最后由 china_shy_wzb 于 2020-7-20 13:58 编辑

鼠标滚轮的实际应用

liu496324 发表于 2023-7-6 08:35:16

楼主威武，牛拜

gujin163 发表于 2024-2-7 11:20:44

啥也不说了，帖子就是带劲！

gujin163 发表于 2024-2-7 11:21:45

太谢谢老大的分享了。
页: [1]
查看完整版本: 【VB6】鼠标滚轮支持模块