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

 

[Dudu2]

Ah oui, bizarre. Je n'ai pas ça. 32 bits ?

 

[patricktoulon]

pour info voila mes resultats

et pas besoin d'une UAG

j'ai beau tout faire pour crasher excel je n'y arrive pas c'est top
le module est tellement simple que ça fait pleurer dit !! 🤪 🤣 🤣 🤣
quand je pense que pendant des années on c'est fait C... avec le hooking

@Dudu2

Ah oui, bizarre. Je n'ai pas ça. 32 bits ?

ça c'est quand on fait des usines a gaz qui devienne presque trop lourdes en mémoire pour vba
tout le monde n'a pas la même puissance
avec mon code simple je n'ai pas ce soucis et d'après les retours il semblerais qu'un large panel de config soit compatible
c'est gagnant gagnant

 

[ChTi160]

Bonjour le Fil
je ne sais pas si ça déjà était validé W11 365 32
Merci Patrick et à ceux qui ont participé !
Jean marie

 

[jurassic pork]

Comme on pouvait s'en douter dans le dernier classeur de patricktoulon, il n' y a que la version IAccessible qui fonctionne avec Excel 2007 sous Windows 7 SP1 . GetDpiForWindow n'est pas trouvé dans les deux autres versions.

 

[patricktoulon]

re
oui iaccessible adopté
il est plus simple de contrôler un point X,Y qu'un rect
c'est vrai que iaccessible je l'avais laisser un peu de coté car il etait tres critiqué dans l'autre monde excel ou tu a retrouvé mon exemple pour le ribbon
mais visiblement stabilisé aujourd'hui
comme quoi je devrais rechercher tout mes vieux trucs , je pourrais retrouver des pépites
dans la ressource je n'ai mis que celui là avec le control copilote et userform géré

 

[patricktoulon]

Maintenant on va travailler à la methode pour les activX qui sont sur feuille
sans faire une usine à GAZ @Dudu2 pollue assez comme ça 🤣 🤣 🤣 🤣 🤣

avec une listebox sur feuille
l'erreur se declenche ici

 criter = (PosControl.accName = MouseControl.accName)

 

[jurassic pork]

Arf ! Patricktoulon tu nous as mis encore une vidéo longue youtube (21 minutes) dans la présentation de ta ressource. Moi dès qu'une vidéo fait plus de 5 minutes je ne la regarde pas. Je pense qu'une simple animation gif comme celle du #32 suffirait. La plupart des personnes qui s'intéressent à une ressource ne cherche pas à savoir comme cela a été créé dans les détails mais plutôt à voir rapidement à quoi cela correspond. Tu as du passé du temps à faire ta vidéo mais une vidéo est surtout intéressante quand il s'agit d'une ressource complexe (comme le CreatorRibbonX)

 

[Dudu2]

accName sur ActiveX je l'ai eu aussi !

 

[jurassic pork]

accName sur ActiveX je l'ai eu aussi !

Avec FlaUInspector on voit que le Name n'est pas supporté pour un activeX listbox dans une feuille pour IAccessible (LegacyIAccessible Pattern)

 

[ChTi160]

Bonjour le Fil
Une remarque pour faire avancer le Schmilblick !
j’ai par exemple une ListBox qui peut afficher par exemple 15 Lignes (visibles) , si mon filtre me fait remonter 20 Lignes , j’arrive à afficher les lignes en descendant , mais lorsque je remonte je n’arrive pas à afficher la première Ligne ! pareil pour un Combobox.
y'a t'il une solution ?
voir la petite vidéo Lol
Jean marie
oupss : Version Module

 

[patricktoulon]

j'ai trouvé la parade mais mais il faudrait que la listbox s'active des le passage de la souris dessus
j'ai pris un de mes viex trucs

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

 

[patricktoulon]

punaise si je commence a perdre la mémoire il faut que je m’inquiète
c'est incroyable j'ai déja les trucs et je les utilises pas
on a tout simplement la même chose que iaccessibleobjectfrompoint avec activewindow.rangefrompoint
qui me donne "OLEObject" quand je passe sur la listbox
mais ca ne fonctionne pas avec le combobox

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

et voila et c'est aussi fluide que dans le userform

 

[Piment]

Bonjour à tous,
Une fois de plus super boulot Patrick.
J'ai intégré ton module dans l'un de mes fichiers, et avec les ComboBox cela fonctionne Impec!
Par contre j'ai repris les codes de la listBox pour l'affecter à une Listview, et cela ne fonctionne pas.
Message d'erreur: "Erreur de compilation. La déclaration de la procédure ne correspond pas à la description de l'évènement ou de la procédure du même nom".
J'ai installé le module sur mon fichier.
Ce serait bien que ça fonctionne aussi avec les ListView.
Merci pour ce partage.

 

[patricktoulon]

Bonjour piment
les listviews n'en ont pas besoin elle l'ont nativement le scrollroulette

 

[Piment]

Re Patrick.
Effectivement, je n'avais pas fait attention: autant pour moi.
Merci encore pour ce partage.
Salutations de la Réunion (dis donc tu est lève tôt toi: 6 heures du matin chez toi!) et déjà sur ta machine!