我尝试使用peter Peter Thornton代码，它允许选项在组合框和列表框中滚动鼠标，这个选项不是在excel中构建的，它对于用户形式的Combox和列表框很有效但我可以＆ ＃39;似乎了解如何使此代码适用于工作表上的常规ComboBox
模块代码：
'Enables mouse wheel scrolling in controls
Option Explicit
#If Win64 Then
Private Type POINTAPI
XY As LongLong
End Type
#Else
Private Type POINTAPI
X As Long
Y As Long
End Type
#End If
Private Type MOUSEHOOKSTRUCT
Pt As POINTAPI
hWnd As Long
wHitTestCode As Long
dwExtraInfo As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long ' not sure if this should be LongPtr
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" _
Alias "GetWindowLongPtrA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
#End If
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As LongPtr, _
ByVal hmod As LongPtr, _
ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
ByVal hHook As LongPtr, _
ByVal nCode As Long, _
ByVal wParam As LongPtr, _
lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
ByVal hHook As LongPtr) As LongPtr ' MAYBE Long
'Private Declare PtrSafe Function PostMessage Lib "user32.dll" _
' Alias "PostMessageA" ( _
' ByVal hwnd As LongPtr, _
' ByVal wMsg As Long, _
' ByVal wParam As LongPtr, _
' ByVal lParam As LongPtr) As LongPtr ' MAYBE Long
#If Win64 Then
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal Point As LongLong) As LongPtr '
#Else
Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As LongPtr '
#End If
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
ByRef lpPoint As POINTAPI) As LongPtr 'MAYBE Long
#Else
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
#End If
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
Dim n As Long
Private mCtl As Object
Private mbHook As Boolean
#If VBA7 Then
Private mLngMouseHook As LongPtr
Private mListBoxHwnd As LongPtr
#Else
Private mLngMouseHook As Long
Private mListBoxHwnd As Long
#End If
Sub HookListBoxScroll(frm As Object, ctl As Object)
Dim tPT As POINTAPI
#If VBA7 Then
Dim lngAppInst As LongPtr
Dim hwndUnderCursor As LongPtr
#Else
Dim lngAppInst As Long
Dim hwndUnderCursor As Long
#End If
GetCursorPos tPT
#If Win64 Then
hwndUnderCursor = WindowFromPoint(tPT.XY)
#Else
hwndUnderCursor = WindowFromPoint(tPT.X, tPT.Y)
#End If
If TypeOf ctl Is UserForm Then
If Not frm Is ctl Then
ctl.SetFocus
End If
Else
If Not frm.ActiveControl Is ctl Then
ctl.SetFocus
End If
End If
If mListBoxHwnd <> hwndUnderCursor Then
UnhookListBoxScroll
Set mCtl = ctl
mListBoxHwnd = hwndUnderCursor
#If Win64 Then
lngAppInst = GetWindowLongPtr(mListBoxHwnd, GWL_HINSTANCE)
#Else
lngAppInst = GetWindowLong(mListBoxHwnd, GWL_HINSTANCE)
#End If
' 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
#If VBA7 Then
Private Function MouseProc( _
ByVal nCode As Long, ByVal wParam As Long, _
ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
Dim idx As Long
On Error GoTo errH
If (nCode = HC_ACTION) Then
#If Win64 Then
If WindowFromPoint(lParam.Pt.XY) = 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 TypeOf mCtl Is Frame Then
If lParam.hWnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
ElseIf TypeOf mCtl Is UserForm Then
If lParam.hWnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
Else
If lParam.hWnd > 0 Then idx = -1 Else idx = 1
idx = idx + mCtl.ListIndex
If idx >= 0 And idx <= mCtl.ListCount - 1 Then
mCtl.ListIndex = idx
End If
Exit Function
End If
Else
UnhookListBoxScroll
End If
#Else
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 TypeOf mCtl Is Frame Then
If lParam.hWnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
ElseIf TypeOf mCtl Is UserForm Then
If lParam.hWnd > 0 Then idx = -10
Else
idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
Else
If lParam.hWnd > 0 Then idx = -1 Else idx = 1
idx = idx + mCtl.ListIndex
If idx >= 0 And idx <= mCtl.ListCount - 1 Then
mCtl.ListIndex = idx
End If
Exit Function
End If
Else
UnhookListBoxScroll
End If
#End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
#Else
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 TypeOf mCtl Is Frame Then
If lParam.hWnd > 0 Then idx = -10 Else idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
ElseIf TypeOf mCtl Is UserForm Then
If lParam.hWnd > 0 Then
idx = -10
Else
idx = 10
idx = idx + mCtl.ScrollTop
If idx >= 0 And idx < ((mCtl.ScrollHeight - mCtl.Height) + 17.25) Then
mCtl.ScrollTop = idx
End If
Else
If lParam.hWnd > 0 Then idx = -1 Else idx = 1
idx = idx + mCtl.ListIndex
If idx >= 0 And idx <= mCtl.ListCount - 1 Then
mCtl.ListIndex = idx
End If
Exit Function
End If
Else
UnhookListBoxScroll
End If
End If
MouseProc = CallNextHookEx( _
mLngMouseHook, nCode, wParam, ByVal lParam)
Exit Function
errH:
UnhookListBoxScroll
End Function
#End If
当前用户表单代码：
Private Sub cmbMyList_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.cmbMyList
End Sub
Private Sub lbxMyList_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
HookListBoxScroll Me, Me.lbxMyList
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnhookListBoxScroll
End Sub
当前的ComboBox代码：
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
End Sub
答案 0 :(得分：0)
由Jaafar Tribak解决
我目前使用的代码（将其放在任何模块中）：
Option Explicit
Type POINTAPI
X As Long
Y As Long
End Type
Type MSLLHOOKSTRUCT
pt As POINTAPI
mouseData As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
#If VBA7 Then
#If Win64 Then
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongLong) As LongPtr
#Else
Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If
Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As LongPtr
Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function IsWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As LongPtr
Dim hwnd As LongPtr, lMouseHook As LongPtr
#Else
Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
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
Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Dim hwnd As Long, lMouseHook As Long
#End If
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Const HC_ACTION = 0
Dim oComboBox As Object
Sub SetComboBoxHook(ByVal Control As Object)
Dim tPt As POINTAPI
Dim sBuffer As String
Dim lRet As Long
Set oComboBox = Control
RemoveComboBoxHook
GetCursorPos tPt
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, tPt, LenB(tPt)
hwnd = WindowFromPoint(lPt)
#Else
hwnd = WindowFromPoint(tPt.X, tPt.Y)
#End If
sBuffer = Space(256)
lRet = GetClassName(GetParent(hwnd), sBuffer, 256)
If InStr(Left(sBuffer, lRet), "MdcPopup") Then
SetFocus hwnd
#If Win64 Then
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.HinstancePtr, 0)
#Else
lMouseHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, Application.Hinstance, 0)
#End If
End If
End Sub
Sub RemoveComboBoxHook()
UnhookWindowsHookEx lMouseHook
End Sub
#If VBA7 Then
Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, lParam As MSLLHOOKSTRUCT) As LongPtr
#Else
Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, lParam As MSLLHOOKSTRUCT) As Long
#End If
Dim sBuffer As String
Dim lRet As Long
sBuffer = Space(256)
lRet = GetClassName(GetActiveWindow, sBuffer, 256)
If Left(sBuffer, lRet) = "wndclass_desked_gsk" Then Call RemoveComboBoxHook
If IsWindow(hwnd) = 0 Then Call RemoveComboBoxHook
If (nCode = HC_ACTION) Then
If wParam = WM_MOUSEWHEEL Then
#If Win64 Then
Dim lPt As LongPtr
CopyMemory lPt, lParam.pt, LenB(lParam.pt)
If WindowFromPoint(lPt) = hwnd Then
#Else
If WindowFromPoint(lParam.pt.X, lParam.pt.Y) = hwnd Then
#End If
On Error Resume Next
If lParam.mouseData > 0 Then
oComboBox.TopIndex = oComboBox.TopIndex - 1 '<---u can change this to change the scrolling speed upwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
Else
oComboBox.TopIndex = oComboBox.TopIndex + 2 '<---u can change this to change the scrolling speed downwards
'u can change "TopIndex" to "listIndex" if you want to change the value instead of hovering it, do not use the dynamic listFillrange if u do!
End If
On Error GoTo 0
End If
End If
End If
MouseProc = CallNextHookEx(lMouseHook, nCode, wParam, ByVal lParam)
End Function
组合框代码（组合框的视图代码）：
Option Explicit
'optional
Dim ComboBoxRange As Range
Dim myRange As Range
Dim NumRows
'optional
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call SetComboBoxHook(ComboBox1)
End Sub
Private Sub ComboBox1_LostFocus()
Call RemoveComboBoxHook
End Sub
'optional, this code is for a dynamic list, do not use if u changed TopIndex to ListIndex!
'importent note...u need a dynamic list to begin with if u want to use it!
Private Sub ComboBox1_Change()
Set myRange = Range("Q:Q") 'the range of data
NumRows = Application.WorksheetFunction.Count(myRange)
'////////////////////////////////////////////////////////////////
Set ComboBoxRange = Range(Cells(4, 17), Cells(3 + NumRows, 17))
'my data starts at range Q4, Q = 17, A=1, change this according to the range you want to change
'////////////////////////////////////////////////////////////////
ComboBox1.ListFillRange = ComboBoxRange.Cells.Address
ComboBox1.DropDown
End Sub
'optional