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

Private 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, tbx  ' Modif (tbx ajouté)
    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
        On Error Resume Next   ' Modif masquage des erreurs
        criter = False                  ' Modif
        criter = (posControl.accName = MouseControl.accName)
        If Not criter Then bLooping = False: Exit Sub
        On Error GoTo 0             ' Modif   gestion des erreurs réactivée
        bLooping = True
        Call WaitMessage
        If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
            lDelta = HiWord(tMsg.wParam)
            If pilote Is Nothing Then
                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, control.ScrollHeight) ' Modif (control au lieu de Frame1)
                        End If
                    Case "ListBox", "ComboBox"
                        If lDelta > 0& Then
                            tbx = "moins"
                            On Error Resume Next
                            control.TopIndex = Application.Max(control.TopIndex - 1, 0) ' Modif ( , 0 au lieu de , 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
            If Not pilote Is Nothing Then
                Select Case TypeName(pilote)
                    Case "ScrollBar"
                        If lDelta > 0& Then
                            tbx = "moins"
                            pilote.Value = Application.Max(pilote.Value - pilote.LargeChange, pilote.Min)
                        Else
                            tbx = "plus"
                            pilote.Value = Application.Min(pilote.Value + pilote.LargeChange, pilote.Max)
                        End If
                        'On peut ici ajouter des control piloté par un autre comme pour le scrollbar
                 End Select
            End If
        End If 'End of PeekMessage
        DoEvents
    Loop Until bLooping = False
End Sub

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 CmbB_Periode_4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If bLooping = False Then MouseWheelOut CmbB_Periode_4, Y
End Sub
Private Sub CmbB_Periode_5_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If bLooping = False Then MouseWheelOut CmbB_Periode_5, Y
End Sub
Private Sub LstB_Recherches_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If bLooping = False Then MouseWheelOut LstB_Recherches, Y
End Sub

 Option Explicit
Public 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
Private Declare PtrSafe Function GetDpiForWindow Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
#If Win64 Then
Private Const NULL_PTR = 0
#Else
Private Const NULL_PTR = 0&
#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 GetDpiForWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Function HiWord(Param As Long) As Integer
Call CopyMemory(HiWord, ByVal VarPtr(Param) + 2&, 2&)
End Function
#End If

Sub MouseWheelOut(control As Object, Optional yy As Single = 0, Optional pilote As Object = Nothing)
Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
Dim tMsg As Msg, lDelta As Integer, pos As POINTAPI, criter As Boolean, A
A = EmplacementControl(control, yy)
Do
GetCursorPos pos
criter = pos.X > A(0) And pos.X < A(2) And pos.Y > A(1) And pos.Y < A(3)
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)
If pilote Is Nothing Then
Select Case TypeName(control)
Case "Frame"
If lDelta > 0& Then
control.ScrollTop = Application.Max(control.ScrollTop - 8, 0)
Else
control.ScrollTop = Application.Min(control.ScrollTop + 8, control.ScrollHeight)
End If
Case "ListBox", "ComboBox"
If lDelta > 0& Then
On Error Resume Next
control.TopIndex = Application.Max(control.TopIndex - 1, 1)
On Error GoTo 0
Else
On Error Resume Next
control.TopIndex = Application.Min(control.TopIndex + 1, control.ListCount - 1)
On Error GoTo 0
End If
End Select
End If
If Not pilote Is Nothing Then
Select Case TypeName(pilote)
Case "ScrollBar"
If lDelta > 0& Then
pilote.Value = Application.Max(pilote.Value - pilote.LargeChange, pilote.Min)
Else
pilote.Value = Application.Min(pilote.Value + pilote.LargeChange, pilote.Max)
End If
End Select
End If
End If 'End of PeekMessage
DoEvents
Loop Until bLooping = False
End Sub

 ' 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#
PPx = 1 / (GetDpiForWindow(Application.hWnd) / 72)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