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

QQ登录

只需一步,快速开始

搜索
热搜: 下载 VB C 实现 编写
查看: 5395|回复: 6

【VB6】鼠标滚轮支持模块

[复制链接]

1109

主题

1648

回帖

7万

积分

用户组: 管理员

一只技术宅

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

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

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

×
用法:调用EnableMouseWheel使特定控件支持滚轮消息。滚轮消息发生后,Ctrl.OnMouseWheelCallBack会被调用。
OnMouseWheelCallBack的参数列表必须是(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
你可以在一个Form窗体里写这个过程,就像这样:
  1. Sub OnMouseWheelCallBack(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
  2. If hWnd = 某控件.hWnd Then '判断是哪个控件发生了鼠标滚轮事件
  3.     '处理滚轮消息
  4.     'Delta是滚动值,通常为 120 或者 -120
  5.     'X和Y是鼠标滚轮被搓动的时候,鼠标指针的坐标(相对于控件左上角)
  6. End If
  7. End Sub
复制代码
以下是这个模块的源码。顺带我想知道,我是把Ctrl定义为Object,并且调用了它的OnMouseWheelCallBack。不是所有的Object都有OnMouseWheelCallBack方法的,VB6是在编译的时候确定OnMouseWheelCallBack的地址还是在运行的时候确定OnMouseWheelCallBack的地址?求解答……
  1. Option Explicit
  2. Private Type CtrlWndProcData_t
  3.     Ctrl As Object '被调用OnMouseWheelCallBack的对象
  4.     hWnd As Long
  5.     OldWndProc As Long '旧消息函数
  6. End Type
  7. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
  8. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  9. 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
  10. Private Const GWL_WNDPROC = (-4)
  11. Private Const WM_MOUSEWHEEL = &H20A
  12. Private m_Ctrls() As CtrlWndProcData_t
  13. Private m_NbCtrls As Long
  14. Private m_MaxCtrls As Long
  15. Private Const m_NbCtrlsAlloc As Long = 8
  16. '启用特定控件、窗体对鼠标滚轮事件的支持
  17. '调用后,如果发生了鼠标滚轮事件,Ctrl.OnMouseWheelCallBack会被调用。
  18. 'OnMouseWheelCallBack的参数列表必须是(ByVal hWnd As Long, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long)
  19. Sub EnableMouseWheel(Ctrl As Object, ByVal hWnd As Long)
  20. Dim OldWndProc As Long
  21. OldWndProc = GetWindowLong(hWnd, GWL_WNDPROC)
  22. If OldWndProc = 0 Then Exit Sub
  23. '“注册”hWnd的值到数组里
  24. If m_NbCtrls >= m_MaxCtrls Then
  25.     If m_MaxCtrls Then
  26.         m_MaxCtrls = m_MaxCtrls + m_NbCtrlsAlloc
  27.         ReDim Preserve m_Ctrls(m_MaxCtrls - 1)
  28.     Else
  29.         m_MaxCtrls = m_NbCtrlsAlloc
  30.         ReDim m_Ctrls(m_MaxCtrls - 1)
  31.     End If
  32. End If
  33. With m_Ctrls(m_NbCtrls)
  34.     Set .Ctrl = Ctrl
  35.     .hWnd = hWnd
  36.     .OldWndProc = OldWndProc
  37. End With
  38. m_NbCtrls = m_NbCtrls + 1
  39. 'Hook消息处理函数
  40. SetWindowLong hWnd, GWL_WNDPROC, AddressOf ProcMouseWheel
  41. End Sub
  42. '控件、窗体被销毁前需要调用这个函数恢复旧的消息函数值
  43. Sub DisableMouseWheel(ByVal hWnd As Long)
  44. Dim I&
  45. For I = 0 To m_NbCtrls - 1
  46.     If m_Ctrls(I).hWnd = hWnd Then
  47.         If m_Ctrls(I).OldWndProc Then SetWindowLong hWnd, GWL_WNDPROC, m_Ctrls(I).OldWndProc
  48.         m_NbCtrls = m_NbCtrls - 1
  49.         m_Ctrls(I) = m_Ctrls(m_NbCtrls)
  50.         m_MaxCtrls = m_NbCtrls
  51.         If m_MaxCtrls Then ReDim Preserve m_Ctrls(m_MaxCtrls - 1) Else Erase m_Ctrls
  52.     End If
  53. Next
  54. End Sub
  55. '窗口消息处理函数
  56. Private Function ProcMouseWheel(ByVal hWnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long
  57. Dim I&
  58. For I = 0 To m_NbCtrls - 1 '从“注册”了的hWnd里面找匹配的
  59.     If m_Ctrls(I).hWnd = hWnd Then
  60.         If Msg = WM_MOUSEWHEEL Then
  61.             '找到后就调用OnMouseWheelCallBack方法
  62.             m_Ctrls(I).Ctrl.OnMouseWheelCallBack hWnd, (wp And &HFFFF0000) \ &H10000, lp And &HFFFF&, (lp And &HFFFF0000) \ &H10000
  63.         End If
  64.         '用原有的消息处理函数去处理剩下的消息
  65.         ProcMouseWheel = CallWindowProc(m_Ctrls(I).OldWndProc, hWnd, Msg, wp, lp)
  66.     End If
  67. Next
  68. End Function
复制代码

本帖被以下淘专辑推荐:

回复

使用道具 举报

13

主题

49

回帖

513

积分

用户组: 大·技术宅

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

支持啊。。。
回复

使用道具 举报

12

主题

35

回帖

959

积分

用户组: 大·技术宅

UID
3517
精华
1
威望
36 点
宅币
802 个
贡献
33 次
宅之契约
0 份
在线时间
207 小时
注册时间
2018-3-2
发表于 2018-3-3 19:54:04 | 显示全部楼层
做系统用的吧
回复 赞! 靠!

使用道具 举报

1

主题

60

回帖

333

积分

用户组: 中·技术宅

UID
6035
精华
0
威望
2 点
宅币
266 个
贡献
0 次
宅之契约
0 份
在线时间
29 小时
注册时间
2020-7-7
发表于 2020-7-8 10:22:11 | 显示全部楼层
本帖最后由 china_shy_wzb 于 2020-7-20 13:58 编辑

鼠标滚轮的实际应用
回复 赞! 靠!

使用道具 举报

0

主题

22

回帖

39

积分

用户组: 初·技术宅

UID
8351
精华
0
威望
2 点
宅币
13 个
贡献
0 次
宅之契约
0 份
在线时间
1 小时
注册时间
2023-7-5
发表于 2023-7-6 08:35:16 | 显示全部楼层
楼主威武,牛拜
回复 赞! 靠!

使用道具 举报

1

主题

157

回帖

579

积分

用户组: 大·技术宅

UID
7535
精华
0
威望
0 点
宅币
421 个
贡献
0 次
宅之契约
0 份
在线时间
65 小时
注册时间
2021-10-16
发表于 2024-2-7 11:20:44 | 显示全部楼层
啥也不说了,帖子就是带劲!
回复 赞! 靠!

使用道具 举报

1

主题

157

回帖

579

积分

用户组: 大·技术宅

UID
7535
精华
0
威望
0 点
宅币
421 个
贡献
0 次
宅之契约
0 份
在线时间
65 小时
注册时间
2021-10-16
发表于 2024-2-7 11:21:45 | 显示全部楼层
太谢谢老大的分享了。
回复 赞! 靠!

使用道具 举报

本版积分规则

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

GMT+8, 2024-3-1 04:39 , Processed in 0.043161 second(s), 34 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

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