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

 criter = (PosControl.accName = MouseControl.accName)

Sub MouseWheel(control As Object, Optional yy As Single = 0, Optional pilote As control = Nothing)
    Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg, lDelta As Integer, pos As POINTAPI, criter As Boolean, rc As Rect
    Dim PosControl As IAccessible, MouseControl As IAccessible
    Set MouseControl = control
    Do
        GetCursorPos pos

        If Not TypeOf control.Parent Is Worksheet Then
            #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)
        Else
            rc = GetRectangle(control)
            If pos.X > rc.left And rc.right > pos.X And rc.top < pos.Y And rc.bottom > pos.Y Then
                criter = True
               'rendre actif ici la listbox sinon ca scroll la feuille en même temps '
               'actuellement je suis obligé de la selectionnrer
               Else: criter = False
            End If
        End If
        If Not criter Then RecallLoop = False: Exit Sub

Function GetRectangle(control As Object) As Rect
    Dim ACWP, PPX#, z#
    Set ACWP = ActiveWindow.Panes(1)
     PPX = 1 / (CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / 72)
    z = ACWP.Parent.Zoom / 100
    With GetRectangle
        .left = ACWP.PointsToScreenPixelsX(control.left)
        .top = ACWP.PointsToScreenPixelsY(control.top)
        .right = ACWP.PointsToScreenPixelsX(control.left) + ((control.Width * z) / PPX)
        .bottom = ACWP.PointsToScreenPixelsY(control.top) + ((control.Height * z) / PPX)
    End With
End Function

Sub MouseWheel(control As Object, Optional yy As Single = 0, Optional pilote As control = Nothing)
    Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg, lDelta As Integer, pos As POINTAPI, criter As Boolean, rc As Rect
    Dim PosControl As IAccessible, MouseControl As IAccessible
    Set MouseControl = control
    Do
        GetCursorPos pos
        [B2] = TypeName(ActiveWindow.RangeFromPoint(pos.X, pos.Y))

        If Not TypeOf control.Parent Is Worksheet Then
            #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)
        Else
            If TypeName(ActiveWindow.RangeFromPoint(pos.X, pos.Y)) = "OLEObject" Then
                criter = True
                ActiveSheet.ScrollArea = "A1"
                Else: criter = False: ActiveSheet.ScrollArea = Cells.Address
            End If
        End If
        If Not criter Then RecallLoop = False: Exit Sub