Mouse Wheel Hook (faire défiler le contenu d'une combobox/listbox avec la roulette)

'*******************************************
'multi hook simplifié (molete souris sur activx)
'défilement dans controls liste frame
'patricktoulon
'**********************************
Option Explicit
#If VBA7 Then
    'Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
     Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Any, ByVal Source As Any, ByVal Length As Long)

    '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 SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As LongPtr, ByVal lpFn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As LongPtr) As LongPrt

    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
  
#Else
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    Private Declare PtrSafe 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 PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long

#End If

Private Type POINTAPI: X As Long: Y As Long: End Type
Private Type MSLLHOOKSTRUCT: pt As POINTAPI: mouseData As Long: 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 udtlParamStuct As MSLLHOOKSTRUCT
Public plHooking As Long    ' permet de savoir si le hook est activé ou pas
Public CtrlHooked As Object    ' sera associé à la ListBox

'
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next    'en cas de mouvement très rapide,'évitons les crash en désactivant les erreurs
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                Select Case TypeName(CtrlHooked)    ' déplace l'ascenseur en fonction de la molette ' l'info est stockée dans lParam
                Case "ListBox", "ComboBox": If GetHookStruct(lParam).mouseData > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
                Case "Frame": If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 2 Else .ScrollTop = .ScrollTop + 2
                End Select
            End With
        End If
        Exit Function
    End If
    LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
    If plHooking < 1 Then    ' active le hook s'il n'avait pas déjà été activé
        Set CtrlHooked = ControlToScroll
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    End If
End Sub
Public Sub UnHookMouse()
' désactive le hook s'il existe
    If plHooking <> 0 Then UnhookWindowsHookEx plHooking: plHooking = 0: Set CtrlHooked = Nothing
End Sub