Excelcombobox滚动鼠标
我试图与彼得桑顿代码，使选项滚动鼠标在一个combobox和列表框，一个选项是不是内置在Excel中，它为用户界面Comboxes和列表框令人惊讶，但我似乎无法理解如何使此代码为工作表上的常规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
由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
combobox代码（查看代码到combobox）：
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