技术宅的结界

 找回密码
 立即注册→加入我们

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 929|回复: 2
收起左侧

【VB6】鼠标滚轮支持模块

[复制链接]

995

主题

2207

帖子

5万

积分

用户组: 管理员

一只技术宅

UID
1
精华
197
威望
261 点
宅币
16459 个
贡献
32323 次
宅之契约
0 份
在线时间
1565 小时
注册时间
2014-1-26
发表于 2016-6-25 06:53:00 | 显示全部楼层 |阅读模式

欢迎访问技术宅的结界,请注册或者登录吧。

您需要 登录 才可以下载或查看,没有帐号?立即注册→加入我们

x
用法:调用EnableMouseWheel使特定控件支持滚轮消息。滚轮消息发生后,Ctrl.OnMouseWheelCallBack会被调用。
OnMouseWheelCallBack的参数列表必须是(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
你可以在一个Form窗体里写这个过程,就像这样:
[Visual Basic] 纯文本查看 复制代码
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的地址?求解答……
[Visual Basic] 纯文本查看 复制代码
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

本帖被以下淘专辑推荐:

11

主题

44

帖子

340

积分

用户组: 中·技术宅

UID
2285
精华
0
威望
28 点
宅币
240 个
贡献
0 次
宅之契约
0 份
在线时间
26 小时
注册时间
2017-2-25
发表于 2017-12-23 11:12:56 | 显示全部楼层
本帖最后由 乘简 于 2017-12-25 16:08 编辑

支持啊。。。
回复

使用道具 举报

7

主题

35

帖子

303

积分

用户组: 中·技术宅

UID
3517
精华
0
威望
0 点
宅币
261 个
贡献
7 次
宅之契约
0 份
在线时间
45 小时
注册时间
2018-3-2
发表于 2018-3-3 19:54:04 | 显示全部楼层
做系统用的吧

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|技术宅的结界 ( 滇ICP备16008837号|网站地图

GMT+8, 2018-9-19 01:24 , Processed in 0.100985 second(s), 38 queries , Gzip On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回复 返回顶部 返回列表