Autres toutes versions tester le scrool avec la roulette sans passer par un hooking en addressof

Function EmplacementControl(obj As Object, Optional yy As Single = 0)
    If Not obj Is Nothing Then
        Dim oControl As IAccessible
        Dim oUIA As New CUIAutomation, UIA_Ctrl As IUIAutomationElement
        Dim rect As UIAutomationClient.tagRECT
        Set oControl = obj
        Set UIA_Ctrl = oUIA.ElementFromIAccessible(oControl, 0)
        rect = UIA_Ctrl.CurrentBoundingRectangle
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, tt As Double
        Dim K As Double, PPx, A, z

' fonction du calendar patricktoulon reconvertie
Function EmplacementControl(obj As Object, Optional yy As Single = 0)
    If Not obj Is Nothing Then
        Dim Lft As Double, Ltop As Double, P As Object, PInsWidth As Double, PInsHeight As Double, tt As Double
        Dim K As Double, PPx, A, z
        Lft = obj.Left ' Normalement Page, Frame ou UserForm
        Ltop = obj.Top
        Set P = obj.Parent
        Dim zoo#
        With ActiveWindow.Panes(1)
            zoo = .Parent.Zoom / 100
            PPx = Round(1 / ((.PointsToScreenPixelsY(7200 / zoo) - .PointsToScreenPixelsY(0)) / 7200), 2)
        End With
        Do
            PInsWidth = P.InsideWidth ' Le Page en est pourvu, mais pas le Multipage.
            PInsHeight = P.InsideHeight
            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
            DoEvents
        Loop
        'pour la combobox on considère que le rectangle est le top à la position du curseur+3 left et right
        'il ne peut pas y avoir de raté
        If yy > 0 Then tt = Int(Ltop + obj.Height + yy) + 3 Else tt = Ltop + obj.Height
        EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, tt / PPx)
    End If
End Function

Option Explicit
Private bLooping As Boolean
Private Type POINTAPI: x As Long: Y As Long: End Type
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Type Msg: hWnd As LongPtr: message As Long: wParam As LongPtr: lParam As LongPtr: time As Long: pt As POINTAPI: End Type
    #If Win64 Then
        Private Const NULL_PTR = 0
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
     #Else
        Private Const NULL_PTR = 0&
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    #End If
    Private Function HiWord(Param As LongPtr) As Integer
        Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
    End Function
#Else
    Private Const NULL_PTR = 0&
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Type Msg: hWnd As Long: message As Long: wParam As Long: lParam As Long: time As Long: pt As POINTAPI: End Type
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Function HiWord(Param As Long) As Integer
        Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
    End Function
#End If

Private Sub MouseWheel(control As Object, Optional yy As Single = 0)
    Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg, lDelta As Integer, pos As POINTAPI, criter As Boolean, A
    Dim PosControl As IAccessible, MouseControl As IAccessible
    Set MouseControl = control
    Do
        GetCursorPos pos
        #If Win64 Then
            Dim lngPtr As LongPtr
            CopyMemory lngPtr, pos, LenB(pos)
            AccessibleObjectFromPoint lngPtr, PosControl, 0
        #Else
            AccessibleObjectFromPoint pos.x, pos.Y, PosControl, 0
        #End If
        If PosControl Is Nothing Then Exit Sub
        criter = (PosControl.accName = MouseControl.accName)
        If Not criter Then bLooping = False: Exit Sub
        bLooping = True
        Call WaitMessage
        If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
            lDelta = HiWord(tMsg.wParam)
            Select Case TypeName(control)
                Case "Frame"
                    If lDelta > 0& Then
                        tbx = "moins"
                        control.ScrollTop = Application.Max(control.ScrollTop - 8, 0)
                    Else
                        tbx = "plus"
                        control.ScrollTop = Application.Min(control.ScrollTop + 8, Frame1.ScrollHeight)
                    End If
                Case "ListBox", "ComboBox"
                    If lDelta > 0& Then
                        tbx = "moins"
                        On Error Resume Next
                        control.TopIndex = Application.Max(control.TopIndex - 1, 1)
                        On Error GoTo 0
                    Else
                        tbx = "plus"
                        On Error Resume Next
                        control.TopIndex = Application.Min(control.TopIndex + 1, control.ListCount - 1)
                        On Error GoTo 0
                    End If
            End Select
        End If 'End of PeekMessage
        DoEvents
    Loop Until bLooping = False
End Sub