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

[patricktoulon]

Bonjour a tous
la principal raison des crash excel quand on utilise le hooking de la souris pour avoir le mouse wheel(la roulette)
c'est que le looping avec le (CallnextHook)est asynchrone avec le captage du message de la souris
donc quand une erreur se produit(on va trop vite ou autre)
le looping lui continue parfois au moins une fois même en erreur
résultat comme on déplace le block type du message en mémoire ça crash

je vous propose de tester ceci
ici on va rester dans un do/loop vba classique et le message de la souris sera récupéré par un peekmessage
si il y a une erreur (du au message de la souris non conforme) normalement on a une erreur vba classique
et donc le do/loop est interrompu
donc pas de relance avec un message de la souris erroné donc pas de crash
Vous constaterez que j'augmente l'allocation de la mémoire aussi (64 bits double (longlong ou longPtr))(+2&)

d'autant plus que la dans cette démo je met tout dans le userform
ce qui n'est pas possible avec un code de hooking bien entendu
et ça peut avoir un avantage lorsque l'on veut distribuer un interface(userform) sans devoir l'accompagner de x modules

toujours pareil pour déterminer le rectangle je me sert de ma fonction perso du calendar que j'ai modifié pour ce besoins
donc testez et si ça fonctionne je ferais une ressource au propre

merci d'avance pour votre participation

j'en connais un qui vas ouvrir grand les yeux 🤣

Patrick

 

[patricktoulon]

bon ben voila la version de @jurassic pork avec accrole
si on est pa"s da"ns la listbox ou la child développée de la combo l'event move des control ne declenche rien
et le blocage de la" scrollarea" se fait au depart et en sorti
ca allege la chose et rend plus fluide le scroll dans les controls

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
    #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 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
Function IsScrollable()
    Dim PosControl As IAccessible, pos As POINTAPI
    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
    [c1] = PosControl.accRole
    IsScrollable = PosControl.accRole = 33
End Function

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, criter As Boolean, A
    Dim PosControl As IAccessible
    criter = IsScrollable
    If Not criter Then Exit Sub
    ActiveSheet.ScrollArea = control.TopLeftCell.Address 'bloque le scrollarea de la feuille a la cellule la plus proche du control( EVITE LES PETITS SURSAUTS)
    Do
        criter = IsScrollable
        If Not criter Then
            bLooping = False
            ActiveSheet.ScrollArea = "" 'debloque le scrollarea de la feuille
            control.TopLeftCell.Select 'la selection provoque le replis de la combo
            Exit Sub
        End If
        bLooping = True
        Call WaitMessage
        If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
            lDelta = HiWord(tMsg.wParam)
            If lDelta > 0& Then
                On Error Resume Next
                control.TopIndex = Application.Max(control.TopIndex - 1, 0)
                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 If 'End of PeekMessage
        DoEvents
    Loop While criter
End Sub

a voir si avec accrole on peut pas faire pour les deux (feuille et userform)

 

[Dudu2]

 

[Dudu2]

toujours ce problème de doublage de control

Je sais pas comment tu fais pour avoir ça. Chez moi, Windows 10 / 64 bits, Office 2016 / 32 bits je n'ai pas du tout ça.
Faudrait voir avec d'autres testeurs.

 

[jurassic pork]

Je sais pas comment tu fais pour avoir ça. Chez moi, Windows 10 / 64 bits, Office 2016 / 32 bits je n'ai pas du tout ça.
Faudrait voir avec d'autres testeurs.

Hello Dudu2,
chez moi ton classeur ne fonctionne pas (erreur de compilation dans la déclaration des API) en Excel 2021 64 bits, Windows 11
Ami calmant, J.P

 

[patricktoulon]

@Dudu2 c'est peut être du au 2013 32 bits j'en sais rien en fait
dans tout les cas ça peut pas être bon
il faut que çà marche chez tout le monde
je suis en train de finaliser une version globale(feuille et userform) avec le même code avec accRole
tu verra ça marchera chez toi et moi sans problème
en tout cas chez moi c'est fluide le rythme du scroll et cohérent avec le roulage de la roulette (chez toi c'est pas le cas)
et si c'est pas le cas ça veut dire que tu gère mal les swap de relance avec le move d'ailleurs @jurassic pork aussi

un seul défaut pour le moment avec ce AccRole c'est pour les controls piloté
comme le control piloté est au dessus le control pilote n'est plus pris en compte (ce qui n'etait pas le cas avec accName
laisse moi quelques minutes encore pour tout tester

alors démo Userform

démo sur feuille

je sais pas si vous faite la différence mais vous voyez bien que le scroll est beaucoup plus fluide et cohérent avec mon doigt sur la roulette
laisser moi finaliser
5 minutes

 

[Dudu2]

@jurassic pork,
Tu peux corriger STP ? Je n'ai pas d'Office 64bits sous la main pour tester.

@patricktoulon,
Je ne sais pas quel fichier tu utilises pour ton GIF animé. C'est un peu toujours le même problème.
Moi j'ai pris ton fichier du Post #75 et si je joue avec le Scroll de la ListBox j'ai rapidement une erreur de pile saturée.

 

[jurassic pork]

@jurassic pork,
Tu peux corriger STP ? Je n'ai pas d'Office 64bits sous la main

La déclaration de la fonction PointToLongLong il faut que tu la mettes en dernier dans les déclarations :

#If Win64 Then
     Function PointToLongLong(point As POINTAPI) As LongLong
            Dim ll As LongLong
            Dim cbLongLong As LongPtr
            cbLongLong = LenB(ll)
            ' make sure the contents will fit
            If LenB(point) = cbLongLong Then
                CopyMemory ll, point, cbLongLong
            End If
            PointToLongLong = ll
        End Function
#End If

Tu peux la mettre aussi à la fin de tout ton code

 

[patricktoulon]

oui je sais avec mon exemplaire windowfrompoint on a ce problème je l'ai vu
ça te donne une idé déja de ce qui va pas dans nos version avec hooking
je suis persuadé que c'est encore un problème d'octets du lenB dans le copymemory

bon allons y
voici la dernière version avec iaccessible et AccRole ( userform et feuille )

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'        MODULE DE SCROLLING SUR CONTROLS ACTIVX DANS FEUILLE ET USERFORM SANS HOOKING!!!!!!
'Auteurs:
'@jurassic pork
'@patricktoulon
'version:1.6
'date version:13/03/2025
' Dans cet exercice on utilisera pas le hooking mouse
'on utilse le peekmessage avec condition sur l'object Iaccessible dans un do/loop avec doevents
'dans ce do/loop on surveille la sortie  de l'Iaccesible et on sort  si le curseur n'est plus sur le control
'dans cette version on utilise le m^$eme code pour les controls dans feuille et userform
'****************************************************************************************************

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
    #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 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
Function IsScrollable(control) As Boolean
    Dim PosControl As IAccessible, pos As POINTAPI, ok As Boolean, role
    Select Case True
        Case TypeName(control) = "ListBox": role = 33
        Case TypeOf control Is ComboBox: role = 33
        Case TypeOf control Is Frame: role = 20
        Case TypeOf control Is Image: role = 40
        Case TypeOf control Is UserForm: role = 16
        Case TypeOf control Is ScrollBar: role = 3
    End Select
    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
    On Error Resume Next
    'permet de continuer  à scroller quand on est dans le périmètre  de la combobox originale
    If PosControl.accRole = 46 And bLooping Then IsScrollable = True: Exit Function 'ne fonctionne  que dans le userform
    [c1] = PosControl.accRole
    ok = PosControl.accRole = role
    IsScrollable = ok
End Function

'ici on capte le message de la souris  et selon le messgae on appelle la sub scroller qui gère toute les sorte de control
Sub MouseWheelOut(control As Object, Optional pilote As Object = Nothing)
    Const WHEEL_DELTA = 120&, WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg, lDelta As Integer, criter As Boolean, A
    Dim PosControl As IAccessible
    criter = IsScrollable(control) 'on controle si on est bon pour scroller (permet de pouvoir  atteindre le dropbutton de la combo)
    If Not criter Or bLooping Then Exit Sub
    If Not TypeOf control Is UserForm Then If TypeName(control.Parent) = "Worksheet" Then ActiveSheet.ScrollArea = control.TopLeftCell.Offset(1).Address 'bloque le scrollarea de la feuille a la cellule la plus proche du control( EVITE LES PETITS SURSAUTS)
    Do
        criter = IsScrollable(control)
        If Not criter Then
            bLooping = False
            If Not TypeOf control Is UserForm Then If TypeName(control.Parent) = "Worksheet" Then ActiveSheet.ScrollArea = "" 'debloque le scrollarea de la feuille
            If Not TypeOf control Is UserForm Then If TypeName(control.Parent) = "Worksheet" Then control.TopLeftCell.Offset(1).Select 'la selection provoque le replis de la combo
            Exit Sub
        End If
        bLooping = True
        Call WaitMessage
        If PeekMessage(tMsg, NULL_PTR, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_NOREMOVE) Then
            lDelta = HiWord(tMsg.wParam)
            scroller lDelta, control, pilote
        End If 'End of PeekMessage
        DoEvents
    Loop While criter
End Sub
Sub scroller(lDelta, control, pilote)
    If pilote Is Nothing Then
        If TypeOf control Is UserForm Then
            If lDelta > 0& Then
                control.ScrollTop = Application.Max(control.ScrollTop - 2, 0)
            Else
                control.ScrollTop = Application.Min(control.ScrollTop + 2, control.ScrollHeight)
            End If
        End If
        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, 0)
                    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 ' par control pilote
        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
                'On peut ici ajouter des control piloté par un autre comme pour le scrollbar
        End Select
    End If
End Sub

je join le fichier pour que l'on corrige enssemble si il y a des erreurs
chez moi comme vous l'avez vu dans les captures ca roule tranquille souple pas de galère dans le teston 🤪 🤪

 

[Dudu2]

Ok, merci @jurassic pork, je l'ai donc déplacée en fin de code.
Maintenant, STP, une petite vérif sur ton environnement de ce fichier pour:
1 - Vérifier si il y a double affichage de la ListBox ActiveX comme chez @patricktoulon
2 - Vérifier la fluidité du Scroll
Merci par avance.

 

[Nathe]

Bonjour à tous, je sais pas si ce phénomène est voulu ??

 

[Dudu2]

@patricktoulon,
Le MouseMove appelle (et instancie) la fonction tous les 5/1000ème de seconde sur mon petit PC vu que j'ai stupidement cramé le gros.
Dans mon code, je rejette les appels si le traitement issu du 1er appel est en cours.
Dans ton code, je ne saisis pas bien comment ça fonctionne avec le criter. Mais en agitant la molette rapidement, c'est ce qui provoque la saturation de la pile et c'est peut-être dû à un nombre important d'exécution simultanées de la fonction appelée sur MouseMove.
Juste une hypothèse.

 

[ChTi160]

Bonjour Nathe ,le Fil
j'ai eu le même problème !
j'ai redimensionné la ListBox et plus de problème
Jean marie

 

[Nathe]

Ok, merci @jurassic pork, je l'ai donc déplacée en fin de code.
Maintenant, STP, une petite vérif sur ton environnement de ce fichier pour:
1 - Vérifier si il y a double affichage de la ListBox ActiveX comme chez @patricktoulon
2 - Vérifier la fluidité du Scroll
Merci par avance.

Bonjour, j'ai décidemment des comportements étranges avec vos codes 🙂🙂

 

[patricktoulon]

Bonjour @Nathe normalement non quand tu est dessus le control
le scrollarea de la feuille est bloqué

@Dudu2 laisse tomber la version avec le windowfrompoint prend la dernière

 

[jurassic pork]

Ok, merci @jurassic pork, je l'ai donc déplacée en fin de code.
Maintenant, STP, une petite vérif sur ton environnement de ce fichier pour:
1 - Vérifier si il y a double affichage de la ListBox ActiveX comme chez @patricktoulon
2 - Vérifier la fluidité du Scroll
Merci par avance.

Bon le code n'est pas bon non plus pour du VBA 6.5 (Excel 2007)
A corriger 1 - pour le GetClassName :

#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long 'erreur PtrSafe
    Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function WaitMessage Lib "user32" () 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
#End If

2 - Mettre la déclaration de HighWord64 en même temps que PointToLongLong :

#If Win64 Then
     Function PointToLongLong(point As POINTAPI) As LongLong
            Dim ll As LongLong
            Dim cbLongLong As LongPtr
            cbLongLong = LenB(ll)
            ' make sure the contents will fit
            If LenB(point) = cbLongLong Then
                CopyMemory ll, point, cbLongLong
            End If
            PointToLongLong = ll
      End Function
     Private Function HighWord64(ByVal wParam As LongPtr) As Long
          Call CopyMemory(HighWord64, ByVal VarPtr(wParam) + 2, 4)
     End Function
#End If

N'importe comment avec Excel 2007 et en dessous cela ne fonctionne pas car les Objets ActiveX ne sont pas gérés dans le code des feuilles ( ex :
Me.ListBox1 pas trouvé dans le code de feuille).
J'ai essayé avec Excel 2010 sous windows 7 , là il y a un défaut : quand on utilise le scroll pour la combobox , le scroll de feuille n'est pas bloqué ( ce qu'avait fait patricktoulon dans son code) :