Userform: Scrollen mit dem Mausrad in List- und Comboboxen

[volti]

Liebe Leserin, lieber Leser,

immer wieder wird in Foren danach gefragt, wie man in Userform-Controls wie List- oder Combobox mit dem Mausrad scrollen kann.
Und es existieren ja auch schon viele Beiträge zu dem Thema. Leider auch viele alte Versionen, die dann auf 64 Bit-Office nicht laufen oder mit ewig langen Codes.

Deshalb möchte ich hier mal meine derzeitige Version zeigen, die sowohl auf altem 32 Bit-Excel wie auch auf neuem Excel 32- und 64 Bit bei relativ wenig Code funktioniert.

Insbesondere bei der 64 Bit-Version führt die Verwendung der Longlong-Variablen bei WindowFromPoint gern zu Diskussionen, weshalb ich hier die X,Y-Version darstelle.
Falls es Probleme geben sollte, findest Du aber auch eine Longlong-Variante in der beigefügten Beispieldatei.

Wenn Du nur ein/zwei Listboxen scrollen möchtest, findest Du auch eine extrem codesparende Version ebenfalls in der Beispieldatei.
Diese Version könnte bei Verwendung unter 32 Bit-Office aber auch mal Probleme mit der Handle-Ermittlung haben und außerhalb des Controls noch scrollen. Also, einfach ausprobieren.

So, und nun viel Spaß und Erfolg beim Testen....

Code:

' #### In ein Modul #####
' Mousewheeling in Userform-Controls für 64 und 32 Bit-Office (ohne LongLong)
Option Explicit

Private Type POINTAPI
   X As Long
   Y As Long
End Type

#If VBA7 Then
  Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
          ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#If Win64 Then
   Private Declare PtrSafe Function GetWindowLongA Lib "user32.dll" _
           Alias "GetWindowLongPtrA" ( _
           ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
   Private Declare PtrSafe Function GetWindowLongA Lib "user32" ( _
           ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
 Private Declare PtrSafe Function SetWindowsHookExA Lib "user32.dll" ( _
         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.dll" ( _
         ByVal hHook As LongPtr, ByVal nCode As Long, _
         ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
 Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" ( _
         ByVal hHook As LongPtr) As Long
 Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
         ByRef lpPoint As POINTAPI) As Long
 Private Declare PtrSafe Function GetKeyState Lib "user32.dll" ( _
         ByVal nVirtKey As Long) As Integer
 Private Declare PtrSafe Function PostMessageA Lib "user32.dll" ( _
         ByVal hwnd As LongPtr, ByVal wMsg As Long, _
         ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
 
 Private Type MOUSEHOOKSTRUCT
   PT           As POINTAPI
   lScroll      As LongPtr
   wHitTestCode As Long
   dwExtraInfo  As LongPtr
 End Type
 
 Private mhHook    As LongPtr
 Private mhWndCtrl As LongPtr

#Else
 Private Declare Function WindowFromPoint Lib "user32" ( _
         ByVal xPoint As Long, ByVal yPoint As Long) As Long
 Private Declare Function SetWindowsHookExA Lib "user32.dll" ( _
          ByVal idHook As Long, ByVal lpfn As Long, _
          ByVal hmod As Long, ByVal dwThreadId As Long) As Long
 Private Declare Function CallNextHookEx Lib "user32.dll" ( _
         ByVal hHook As Long, ByVal nCode As Long, _
         ByVal wParam As Long, ByRef lParam As Any) As Long
 Private Declare Function UnhookWindowsHookEx Lib "user32.dll" ( _
         ByVal hHook As Long) As Long
 Private Declare Function GetWindowLongA Lib "user32" ( _
         ByVal hwnd As Long, ByVal nIndex As Long) As Long
 Private Declare Function GetCursorPos Lib "user32.dll" ( _
         ByRef lpPoint As POINTAPI) As Long
 Private Declare Function GetKeyState Lib "user32.dll" ( _
         ByVal nVirtKey As Long) As Integer
 Private Declare Function PostMessageA Lib "user32.dll" ( _
         ByVal hwnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As Long) As Long
 
 Private Type MOUSEHOOKSTRUCT
   PT           As POINTAPI
   lScroll      As Long
   wHitTestCode As Long
   dwExtraInfo  As Long
 End Type
 
 Private mhHook    As Long
 Private mhWndCtrl As Long

#End If

Private Const ciStep        As Integer = 1  ' <<<< Scrollschrittweite setzen >>>>
Private Const WH_MOUSE_LL   As Long = 14
Private Const GWL_HINSTANCE As Long = -6
Private Const WM_KEYDOWN    As Long = &H100
Private mlPage              As Long
Private moControl           As MSForms.control

Public Sub HookMouse(ByRef oControl As MSForms.control, Optional ByVal lPage As Long)
' Hook-Prozedur zum Abfangen der Mausaktivitäten setzen
' Wird nur bei Mausbewegungen im Control angesprungen
  mlPage = lPage
  If mhWndCtrl <> GetHandleUnderMouse Then                          ' Wenn neues Control oder keins mehr
     Call UnhookMouse                                               ' Maus unhooken
     Set moControl = oControl                                       ' Control global machen
     mhWndCtrl = GetHandleUnderMouse                                ' Gleichheit merken
     If mhHook = 0 Then                                             ' Maushook setzen, wenn nicht schon aktiv
        mhHook = SetWindowsHookExA(WH_MOUSE_LL, AddressOf MouseProc, _
                  GetWindowLongA(mhWndCtrl, GWL_HINSTANCE), 0&)
     End If
  End If
End Sub

Public Sub UnhookMouse()
  If mhHook <> 0 Then                                               ' Wenn Maus bereits gehookt
     UnhookWindowsHookEx mhHook                                     ' Maus unhooken
     Set moControl = Nothing                                        ' Objekt zurücksetzen
     mhHook = 0: mhWndCtrl = 0                                      ' Parameter leeren
  End If
End Sub

#If VBA7 Then
Private Function GetHandleUnderMouse() As LongPtr
#Else
Private Function GetHandleUnderMouse() As Long
#End If
  Dim PT As POINTAPI
  
  GetCursorPos PT
  GetHandleUnderMouse = WindowFromPoint(PT.X, PT.Y)
End Function

#If VBA7 Then
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
Private Function MouseProc(ByVal nCode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
#End If
  Dim oControl As MSForms.control, bScrollDown As Boolean, lKeyLeftRight As Long
  Set oControl = moControl
  
  On Error GoTo Fehler
  If nCode = 0 Then ' 0 = HC_ACTION
     If mhWndCtrl = GetHandleUnderMouse() Then                      ' Ist Maus über dem Control?
    
        If wParam = &H20A Then  ' WM_MOUSEWHEEL-Message             ' Mausradaktion verarbeiten
          
           bScrollDown = lParam.lScroll = &H780000                  ' Hoch/runter bzw. links/rechts scrollen?
           lKeyLeftRight = IIf(bScrollDown, vbKeyLeft, vbKeyRight)  ' Taste für links oder rechts setzen
          
           If TypeOf oControl Is MSForms.MultiPage Then Set oControl = oControl.Pages(mlPage)

           With oControl
              If TypeOf oControl Is MSForms.TextBox Then
                 If GetKeyState(vbKeyControl) >= 0 Then             ' Hoch/Runter scrollen
                    .CurLine = IIf(bScrollDown, IIf(.CurLine > ciStep, .CurLine - ciStep, 0), .CurLine + ciStep)
                 Else                                               ' Links/rechts scrollen
                    PostMessageA mhWndCtrl, WM_KEYDOWN, ByVal lKeyLeftRight, 0
                 End If
              
              ElseIf TypeOf oControl Is MSForms.ListBox Then
                 If GetKeyState(vbKeyControl) >= 0 Then             ' Hoch/runter scrollen
                    .TopIndex = IIf(bScrollDown, IIf(.TopIndex > ciStep, .TopIndex - ciStep, 0), .TopIndex + ciStep)
                 Else                                               ' Links/rechts scrollen
                    PostMessageA mhWndCtrl, WM_KEYDOWN, ByVal lKeyLeftRight, 0
                 End If
              
              ElseIf TypeOf oControl Is MSForms.ComboBox Then       ' Hoch/runter scrollen
                 .TopIndex = IIf(bScrollDown, IIf(.TopIndex > ciStep, .TopIndex - ciStep, 0), .TopIndex + ciStep)
          
              Else 'MSForms.MultiPage,MSForms.Userform, MSForms.Frame
                 If GetKeyState(vbKeyControl) >= 0 Then             ' Hoch/runter scrollen
                    .ScrollTop = IIf(bScrollDown, IIf(.ScrollTop > 30, .ScrollTop - 30, 0), .ScrollTop + 30)
                 Else                                               ' Links/rechts scrollen
                    .ScrollLeft = IIf(bScrollDown, IIf(.ScrollLeft > 30, .ScrollLeft - 30, 0), .ScrollLeft + 30)
                 End If
              End If
           End With
           Exit Function
        
        End If
     Else
        Call UnhookMouse
     End If
  End If
  MouseProc = CallNextHookEx(mhHook, nCode, wParam, ByVal lParam)   ' Message an nächsten Prozess weiterleiten
  Exit Function
  
Fehler:
  Call UnhookMouse
End Function


' #### In das Userform-Modul #####
Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call HookMouse(ComboBox1)
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  UnhookMouse
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  UnhookMouse
End Sub
  
Private Sub UserForm_Deactivate()
  UnhookMouse
End Sub

_________
viele Grüße
Karl-Heinz

  Mousewheeling_Beispiele.xlsm (Größe: 77,92 KB / Downloads: 7)