Autres tester le scroll de la frame

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'*******************************************
'hook mouse simplifié (molete souris sur frame)
'défilement dans controls liste frame
'author:patricktoulon

'Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' rouletambour Frame2
'End Sub
'**********************************

Option Explicit

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

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
Const HC_ACTION = 0
Const WH_MOUSE_LL = 14
Const WM_MOUSEWHEEL = &H20A
Public 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

Public pos As POINTAPI
Public EpC As Variant

Sub rouletambour(obj)
    'si ca n'a pas démarrer on demarre  le hook
    If Not CtrlHooked Is Nothing Then If CtrlHooked.Name <> obj.Name Then UnHookMouse
    Call HookMouse(obj)
End Sub
'
Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function

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
    Dim Criter, i&
    GetCursorPos pos
    Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)    'recupère les coordonnée en pixel (left/top/right/bottom du control)
    If Not Criter Then UnHookMouse  'quand on est plus dans le périmètre du control bye bye !!
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
            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é
        EpC = EmplacementControl(ControlToScroll)    'on choppe le rectangle du control par raport à l'ecran(pas du parent!!!!) du control dans un array
        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
' fonction du calendar reconvertie
Function EmplacementControl(obj As Object)
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, K As Double, PPx, A, z
        Lft = obj.Left: Ltop = obj.Top: Set P = obj.Parent    ' Normalement Page, Frame ou UserForm
        With CreateObject("WScript.Shell"): PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72): End With
        Do
            PInsWidth = P.InsideWidth: PInsHeight = P.InsideHeight        ' Le Page en est pourvu, mais pas le Multipage.
            If TypeOf P Is MSForms.Page Then Set P = P.Parent        ' Prend le Multipage, car le Page est sans positionnement.
            K = (P.Width - PInsWidth) / 2: Lft = (Lft + P.Left + K): Ltop = (Ltop + P.Top + P.Height - K - PInsHeight)
            If Not (TypeOf P Is MSForms.Frame Or TypeOf P Is MSForms.MultiPage) Then Exit Do
            Set P = P.Parent
        Loop
        EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height) / PPx)
    End If
End Function

'Switch 64/32 pour la structure du hook de la souris
#If Win64 Then
    Private Type MSLLHOOKSTRUCT:
       'c'est dans cette partie qu'il faut trouver la faille
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As LongPtr
    End Type
#Else
    Private Type MSLLHOOKSTRUCT:
        'valable pour tout les version 32 d'excel vba7 ou vba 6
        'pour 32 ne pas déplacer mousedata et dwExtraInfo car soit ça crashe soit le scroll  ne fonctionne qu'en descente
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
#End If