列表框实现鼠标滚轮滚动Demo

一条狗 · 发表于 2016-2-18 10:04

本帖最后由一条狗于 2016-2-18 10:07 编辑

在论坛一直潜水，快2年了！第一次发帖，功能如题
在论坛找了许久，一直没发现合适的例子可以借鉴，于是自己就各种翻墙，查找资料并DIY这个使用API来控制的实例，现分享给大家，希望给更多人带来帮助

代发分为两部分，Userform和Module
Userform部分

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll
End Sub
Private Sub UserForm_Initialize()
LISTBOX_Post_Flag = 1
LISTBOX_Mouse_Flag = 1
Me.Label1.Caption = "默认：光标位置固定,仅滚轮滚动"
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
Private Sub CommandButton1_Click()
LISTBOX_Post_Flag = 1
LISTBOX_Mouse_Flag = 1
Me.Label1.Caption = "当前状态：光标位置固定,仅滚轮滚动"
End Sub
Private Sub CommandButton2_Click()
LISTBOX_Post_Flag = 1
LISTBOX_Mouse_Flag = 2
Me.Label1.Caption = "当前状态：光标位置不固定,跟随滚轮滚动"
End Sub

复制代码

Module部分

Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type MOUSEHOOKSTRUCT
pt As POINTAPI
hwnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32.dll" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" ( _
ByVal hHook As Long, _
ByVal nCode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" _
Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32.dll" ( _
ByRef lpPoint As POINTAPI) As Long
Private Const WH_MOUSE_LL As Long = 14
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const HC_ACTION As Long = 0
Private Const GWL_HINSTANCE As Long = (-6)
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const VK_UP As Long = &H26
Private Const VK_DOWN As Long = &H28
Private Const WM_LBUTTONDOWN As Long = &H201
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
Private mbHook As Boolean
Public LISTBOX_Post_Flag As Integer
Public LISTBOX_Mouse_Flag As Integer
Sub HookListBoxScroll()
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
mListBoxHwnd = hwndUnderCursor
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
PostMessage mListBoxHwnd, WM_LBUTTONDOWN, 0&, 0&
If Not mbHook Then
mLngMouseHook = SetWindowsHookEx( _
WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
mbHook = mLngMouseHook <> 0
End If
End If
End Sub
Sub UnhookListBoxScroll()
If mbHook Then
UnhookWindowsHookEx mLngMouseHook
mLngMouseHook = 0
mListBoxHwnd = 0
mbHook = False
End If
End Sub
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As Long
On Error GoTo errH 'Resume Next
If (nCode = HC_ACTION) Then
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = mListBoxHwnd Then
If wParam = WM_MOUSEWHEEL Then
MouseProc = True
If lParam.hwnd > 0 Then
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 1 Then frm.ListBox1.TopIndex = frm.ListBox1.TopIndex - 1
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
Else
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 1 Then frm.ListBox1.TopIndex = frm.ListBox1.TopIndex + 1
If LISTBOX_Post_Flag = 1 And LISTBOX_Mouse_Flag = 2 Then PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
End If
PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function

复制代码

aierb · 发表于 2016-4-4 10:50

先顶下，再学习。支持~~

nine_sun · 发表于 2016-12-8 21:31

很好，学习了，非常感谢

一条狗 · 发表于 2016-12-14 15:15

nine_sun 发表于 2016-12-8 21:31
很好，学习了，非常感谢

客气，只是资源整理了一下而已

xunijyj · 发表于 2017-8-11 22:03

谢谢，先记号一下

lysm · 发表于 2017-8-29 16:28

学习分享，谢谢！

aman1516 · 发表于 2017-9-30 10:45

今天用到，学习一下，不然l老出现问题

lcjy11185 · 发表于 2017-10-1 22:54

列表框滚动，好用。做个记号

cx641845586 · 发表于 2017-10-9 17:08

先留个脚印，到时候学习

excelbus · 发表于 2017-11-13 20:09

感谢大神，解决了我几个月的问题，非常感谢啊,也感谢EXCELHOME的小伙伴们

		自动登录	找回密码
密码			免费注册

[分享] 列表框实现鼠标滚轮滚动Demo

评分

评分