鼠标在列表框上滚动
Posted
技术标签:
【中文标题】鼠标在列表框上滚动【英文标题】：Mouse scroll on a listbox 【发布时间】：2016-01-20 21:57:42 【问题描述】：我正在使用 Peter Thornton 的这段代码，它使我能够在用户表单列表框中滚动，但是每次我的鼠标穿过列表框（只是将光标移动到用户表单的另一部分，甚至没有点击）它“激活"列表框。有什么办法可以“阻止”这种情况发生吗？我的意思是，只有当我单击向下箭头打开列表框时，鼠标滚动才能起作用？
这是 Peter Thronton 的代码：
'''''' normal module code
Option Explicit
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
Private mCtl As MSForms.Control
Dim n As Long
Sub HookListBoxScroll(frm As Object, ctl As MSForms.Control)
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
Dim tPT As POINTAPI
GetCursorPos tPT
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
If Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
Set mCtl = ctl
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
Set mCtl = Nothing
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
Dim idx As Long
On Error GoTo errH
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
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_UP, 0
' Else
' PostMessage mListBoxHwnd, WM_KEYDOWN, VK_DOWN, 0
' End If
' PostMessage mListBoxHwnd, WM_KEYUP, VK_UP, 0
If lParam.hwnd > 0 Then idx = -1 Else idx = 1
' idx = idx + mCtl.ListIndex
' If idx >= 0 Then mCtl.ListIndex = idx
idx = idx + mCtl.TopIndex
If idx >= 0 Then mCtl.TopIndex = idx
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
'''''''' end normal module code
【问题讨论】：
HookListBoxScroll 过程中的“ctl.SetFocus”行是激活列表框的内容。如果您删除该部分并将其更改为“退出子”，那么这可能仅在列表框已激活时才有效。可能需要进行更多调整，因为我实际上并没有将此代码放入 Excel 工作簿中进行测试。 已在上面的链接中解决。不过谢谢大家的关注。 =) Excel 2010 UserForm - form does not scroll with Mouse Wheel的可能重复 【参考方案1】：这会起作用 =)
Option Explicit
'This will compile in 32 bit Excel only
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal Destination As Long, ByVal Source As Long, ByVal Length 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 Type POINTAPI
x As Long
Y As Long
End Type
Private Type MSLLHOOKSTRUCT 'Will Hold the lParam struct Data
pt As POINTAPI
mouseData As Long ' Holds Forward\Backward flag
flags As Long
time As Long
dwExtraInfo As Long
End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private Const GWL_HINSTANCE = (-6)
Public Const nMyControlTypeNONE = 0
Public Const nMyControlTypeUSERFORM = 1
Public Const nMyControlTypeFRAME = 2
Public Const nMyControlTypeCOMBOBOX = 3
Public Const nMyControlTypeLISTBOX = 4
Private hhkLowLevelMouse As Long
Private udtlParamStuct As MSLLHOOKSTRUCT
Public myGblUserForm As UserForm
Public myGblControlObject As Object
Public iGblControlType As Integer
Public myGblUserFormControl As Object
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
' VarPtr returns address; LenB returns size in bytes.
CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
GetHookStruct = udtlParamStuct
End Function
Function LowLevelMouseProc _
(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Avoid XL crashing if RunTime error occurs due to Mouse fast movement
Dim iDirection As Long
On Error Resume Next
' \\ Unhook & get out in case the application is deactivated
If GetForegroundWindow <> FindWindow("ThunderDFrame", myGblUserForm.Caption) Then
UnHook_Mouse
Exit Function
End If
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
iDirection = GetHookStruct(lParam).mouseData
Call ProcessMouseWheelMovement(iDirection)
'\\ Don't process Default WM_MOUSEWHEEL Window message
LowLevelMouseProc = True
End If
Exit Function
End If
LowLevelMouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function
Sub Hook_Mouse()
' Statement to maintain the handle of the hook if clicking outside of the control.
' There isn't a Hinstance for Application, so used GetWindowLong to get handle.
If hhkLowLevelMouse < 1 Then
hhkLowLevelMouse = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, _
GetWindowLong(FindWindow("ThunderDFrame", myGblUserForm.Caption), GWL_HINSTANCE), 0)
End If
End Sub
Sub UnHook_Mouse()
If hhkLowLevelMouse <> 0 Then
UnhookWindowsHookEx hhkLowLevelMouse
hhkLowLevelMouse = 0
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'UserForm MouseWheel Code
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ProcessMouseWheelMovement(ByVal iDirection As Long)
'This processes MouseWheel Scrolls
'
'Thank You Mathieu Plante from July 2004
Dim i As Long
Dim iMultiplier As Long
'Debug.Print iDirection, iGblControlType, Now()
Select Case iGblControlType
''''''''''''''''''''''''''''''''''''''''''''''''
'UserForm Mouse Scroll
''''''''''''''''''''''''''''''''''''''''''''''''
Case nMyControlTypeUSERFORM
iMultiplier = 3
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
''''''''''''''''''''''''''''''''''''''''''''''''
'Frame Mouse Scroll
''''''''''''''''''''''''''''''''''''''''''''''''
Case nMyControlTypeFRAME
iMultiplier = 5
If iDirection > 0 Then
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineUp
Next i
Else
For i = 1 To iMultiplier
myGblControlObject.Scroll fmScrollActionNoChange, fmScrollActionLineDown
Next i
End If
''''''''''''''''''''''''''''''''''''''''''''''''
'ComboBox Mouse Scroll
''''''''''''''''''''''''''''''''''''''''''''''''
Case nMyControlTypeCOMBOBOX
With myGblControlObject
'\\ if rolling forward increase Top index by 1 to cause an Up Scroll
If iDirection > 0 Then
.TopIndex = .TopIndex - 1
Else '\\ if rolling backward decrease Top index by 1 to cause a Down Scroll
.TopIndex = .TopIndex + 1
End If
End With
'Debug.Print "Top Index = " & myGblControlObject.TopIndex
''''''''''''''''''''''''''''''''''''''''''''''''
'Listbox Mouse Scroll
''''''''''''''''''''''''''''''''''''''''''''''''
Case nMyControlTypeLISTBOX
With myGblControlObject
'\\ if rolling forward increase Top index by 1 to cause an Up Scroll
If iDirection > 0 Then
.TopIndex = .TopIndex - 1
Else '\\ if rolling backward decrease Top index by 1 to cause a Down Scroll
.TopIndex = .TopIndex + 1
End If
End With
'Debug.Print "Top Index = " & myGblControlObject.TopIndex
End Select
End Sub
感谢 LJMetzer 来自 Excel 论坛。
【讨论】：
这个不能在我的Excel上编译，有人知道原因吗？ @Bandoleras 你必须在 64 位机器上（比如我）。 Check out this *** question/answer 关于如何调整声明的函数以在 64 位环境中工作。以上是关于鼠标在列表框上滚动的主要内容，如果未能解决你的问题，请参考以下文章