Clever-Excel-Forum

'In das Userformmodul
Private Sub LB_API_Fktvor_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call HookMouse(LB_API_Fktvor)
End Sub

Private Sub CB_Such_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call HookMouse(CB_Such)
End Sub

Private Sub UserForm_Deactivate()
  Call UnhookMouse
End Sub



'In ein normales Modul
Option Explicit

Private Type POINTAPI
    X As Long
    Y As Long
End Type
Private PT As POINTAPI

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 Long
#If Win64 Then
   Private Declare PtrSafe Function GetWindowLong Lib "user32" _
           Alias "GetWindowLongPtrA" ( _
           ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
   Private Declare PtrSafe Function WindowFromPoint Lib "user32" ( _
           ByVal point As LongLong) As LongPtr
   Private Declare PtrSafe Sub CopyMemory Lib "kernel32" _
           Alias "RtlMoveMemory" ( _
           Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    Private Declare PtrSafe Function GetWindowLong Lib "user32" _
           Alias "GetWindowLongA" ( _
           ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
   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" ( _
        lpPoint As POINTAPI) As Long
 
Type MOUSEHOOKSTRUCT
   PT            As POINTAPI
   hWnd          As LongPtr
   wHitTestCode  As Long
   dwExtraInfo   As LongPtr
End Type
  
Private hHook    As LongPtr
Private hWndCtrl As LongPtr

Private Const MS_UpDn = 10000000
Private Const WH_MOUSE_LL = 14&
Private Const WM_MOUSEWHEEL = &H20A
Private Const HC_ACTION = 0&
Private Const GWL_HINSTANCE = -6&

Private oControl As MSForms.Control

Public Sub HookMouse(ByRef oMSControl As MSForms.Control)
'Hook-Prozedur zum Anfangen der Mausaktivitäten setzen
'Wird nur bei Mausbewegungen im Control angesprungen
 If hHook = 0 Then
    GetCursorPos PT                                        'Cursorposition holen
    #If Win64 Then
        hWndCtrl = WindowFromPoint(PointToLongLong(PT))
    #Else
        hWndCtrl = WindowFromPoint(PT.X, PT.Y)             'Handle des Controls holen
    #End If
    Set oControl = oMSControl                              'Referenz zum Control setzen
    hHook = SetWindowsHookEx(WH_MOUSE_LL, AddressOf MouseProc, _
            GetWindowLong(hWndCtrl, GWL_HINSTANCE), 0&)    'Neuen Maus-Hook setzen
    DoEvents
 End If
End Sub

Public Sub UnhookMouse()
'Maus unhooken
 UnhookWindowsHookEx hHook
 hHook = 0
 Set oControl = Nothing
End Sub

Private Function MouseProc(ByVal ncode As Long, ByVal wParam As LongPtr, lParam As MOUSEHOOKSTRUCT) As LongPtr
 Dim hWnd As LongPtr
 
 On Error GoTo Fehler
 If ncode = HC_ACTION Then
    #If Win64 Then
        hWnd = WindowFromPoint(PointToLongLong(lParam.PT)) 'Handle Fenster unter Maus 64 Bit
    #Else
        hWnd = WindowFromPoint(lParam.PT.X, lParam.PT.Y)   'Handle Fenster unter Maus 32 Bit
    #End If
    If hWnd <> hWndCtrl Then                               'Wenn Control verlassen wird
       Call UnhookMouse                                    'Maus unhooken
    ElseIf wParam = WM_MOUSEWHEEL Then                     'Mausrad betätigt
       With oControl                                       'Control-Aktionen durchführen
          If lParam.hWnd < MS_UpDn Then
             .TopIndex = .TopIndex - 1                     'Liste runter
          Else
             .TopIndex = .TopIndex + 1                     'Liste rauf
          End If
       End With
    End If
 End If
 MouseProc = CallNextHookEx(hHook, ncode, wParam, lParam) 'Message weiterreichen
 Exit Function

Fehler:
 Call UnhookMouse                                         'Maus unhooken
End Function

#If Win64 Then
'Umwandlung von Point zu LongLong
Function PointToLongLong(point As POINTAPI) As LongLong
   Dim ll As LongLong, cbLongLong As LongPtr
   cbLongLong = LenB(ll)
   If LenB(point) = cbLongLong Then CopyMemory ll, point, cbLongLong
   PointToLongLong = ll
End Function
#End If