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]

Bonsoir @ChTi160 ;
Je n'ai pas réussi à tirer quelque chose des indications de @Rheeem.

 

[patricktoulon]

Bonsoir à tous et à toutes
et voila la petite sœur pour les listboxs et comboboxs sur feuille

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'           MOUSE WHEEL SUR CONTROL SANS PASSER SANS PASSER PAR UN HOOKING SOURIS EN ADDRESSOF
'                   EXEMPLAIRE POUR TRAVAILLER AVEC DES CONTROLS SUR FEUILLE
'
'Auteur :patricktoulon :https://excel-downloads.com/members/patricktoulon.167882/#resources
'Version 1.3 In Module
'Dans cet exercice je montre comment retrouver le mouse wheel pour les controls(listbox/combobox)SUR FEUILLE
'Sans passer par un hooking souris en addressof rendant instable les applicatif  que l'on developpe
'Pour la combobox
'J'ai a l'ocasion modifier ma fonction perso "Emplacementcontrol"
'En effet pour determiner la limte des combobox je me sert de la position "Y" que donne l'event mousemove
'Donc pour la combo le rectangle est left,top,right,y
'Dans le do loop des que l'on bouge  blooping devient false donc l'event rappelle avec la nouvelle position Y
'Ce qui nous donne le nouveau rectangle
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 = GetRectangle(control, yy)
    GetCursorPos pos
    If TypeOf control Is ComboBox Then If pos.Y < A(1) + 20 Then Exit Sub 'permet de naviguer avec la souris pour au moins atteindre le dropbutton sans declencher le do/loop
    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
            ActiveSheet.ScrollArea = Cells.Address 'debloque le scrollarea de la feuille
            control.TopLeftCell.Select: 'la selection provoque le replis de la combo
            Exit Sub
        End If
        bLooping = True
        ActiveSheet.ScrollArea = control.TopLeftCell.Address 'bloque le scrollarea de la feuille a la cellule la plus proche du control( EVITE LES PETITS SURSAUTS)
        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 Until bLooping = False
End Sub

Function GetRectangle(control As Object, Optional yy As Single = 0)
    Dim acwp As Pane, z#, A
    Set acwp = ActiveWindow.Panes(1)
    DoEvents
    Application.ScreenUpdating = True
    With acwp
        z = .Parent.Zoom / 100
        A = Array(.PointsToScreenPixelsX(control.Left), _
                  .PointsToScreenPixelsY(control.Top), _
                  .PointsToScreenPixelsX(control.Left + (control.Width * z)), _
                  .PointsToScreenPixelsY(control.Top + (control.Height * z) + ((yy + 3) * z)))
    End With
    GetRectangle = A
End Function

dans le module de la feuille

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
         If bLooping = False Then MouseWheelOut ComboBox1, 100
End Sub


Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If bLooping = False Then MouseWheelOut ListBox1
End Sub

vous remarquerez que j'adopte le même principe qu'avec emplacement control pour le combobox
a savoir le move déclenche le recalcule du rectangle si on est sorti du précédent calcul
le rectangle c'est le left top right et (la position Y de l'event move+3) en pixel pour le bottom
pour eviter les sursauts je bloque le scrollarea de la feuille pendant que je suis dessus le control

voila encore une fois pas besoins d'une UAG

 

[Dudu2]

Et donc c'est le même module pour ActiveX et UserForm ? Ou différent ?

 

[patricktoulon]

re
il est différent car je n'utilise pas le Iaccessible
après on peut mixer les deux j'ai travaillé sur un support vierge pour être tranquille
mais grossso modo le principe est le même
sauf que sur feuille on travaille avec un rectangle déterminé
ce qui est dommage c'est le rangefrompoint de l'activewindow sur la sub window développée qui donne le range d'en dessous
sinon j'aurais fait le même principe que le iaccessibleobjectfrompoint

ca fait des heures que je bricole avec ça avec des erreur dans mes essais et je n'ai pas eu un seul crash excel
avec nos versions hook on aurait perdu des cheveux déjà

 

[patricktoulon]

non chez moi ton truc ,elle a toujours planté ou tout de suite ou après quelques scroll
moi ce que je propose c'est que les erreur ne créent pas un crash violent

et moi aussi j'en avais fait une bien avant que tu propose ton module et qui fonctionne très bien chez moi mais chez certains provoques des crashs
donc le callnextHook j'en suis revenu et n'y retournerais pas

de tout façon parler de hooking dans cette discussion va a l'encontre du sujet puisque c'est exactement le contraire

j'ai présenté deux versions une avec rectangle emplacementcontrol issue du calendar
et la même avec la modif de @jurassic pork avec iaccessible
et une 3 eme en étude pour les feuilles tiré de la première

quand je vois le code nécessaire je me dit que c'est un bon truc
d'ailleurs je l'ai installé sur mon vba indenter interface et dans d'autres de mes applicatifs
et ça passe comme une lettre a la poste

rien ne t'empêche de rester dans le hooking mais ici on en parlera pas

 

[jurassic pork]

Hello,
patricktoulon, il faudrait que tu nous mettes un classeur de test de ta dernière version car en recopiant ton code cela ne fonctionne pas chez moi. N'importe comment à mon avis cela ne fonctionnera dans un classeur Excel 2007 et inférieur car d'après ce que j'ai constaté dans le Excel 2007, il n'y a pas la gestion des événements des objets ActiveX dans les feuilles.
Ami calmant, J.P

 

[jurassic pork]

Je n'ai pas réussi à tirer quelque chose des indications de @Rheeem.

Ben on arrive quand même à avoir le handle des objets activeX ce qui m'a permis de constater que le Handle du comboBox changeait quand sa liste apparaissait. En fait c'est un nouvel objet qui est créé un objet Liste. Avec cela je comprend maintenant pourquoi le IAccessible ne fonctionnait avec la ComboBox (voir le post #36 de patricktoulon ). J'ai une nouvelle version en cours qui n'utilise le IAccessible.
Ami calmant, J.P

 

[patricktoulon]

re
@jurassic pork ben oui tu n'avais pas compris quand je parlais de sub window pour la combo ?

 

[patricktoulon]

tiens le classeur
le module c'est pour les controls sur feuille2
c'est pas assez fluide pour moi

 

[jurassic pork]

re
@jurassic pork ben oui tu n'avais pas compris quand je parlais de sub window pour la combo ?

dans quel post ?

 

[patricktoulon]

re

Autres Publié dans la discussion 'toutes versions tester le scrool avec la roulette sans passer par un hooking en addressof'

Mercredi à 09:07

Bonjour à tous
oui c'est vrai je suis plutôt matinal coucou la réunion
la correction de remontée au premier item avait été faite me semble t il
après comme dit @jurassic pork je suis parti sur autre chose
du moins pas tout a fait
cette methode fonctionne sur le userform mais pas tout a fait avec les combobox sur feuille
car l'homologue a accessibleobjectfrompoint en l’occurrence activewindow.rangefrompoint(x,y) donne bien l'object pour la listbox mais pour la combobox quand on passe sur la sub fenêtre développée de la combo il donne le range qui est en dessous
c'est...

• patricktoulon

• 

 

[patricktoulon]

avec dudu2 quand on a bricolé avec les api hooking ,on a pris le parti de capter la classe de fenêtre sous le curseur
peut être faire la même chose

le probleme avec windowfrompoint c'est le 64 bit qui faut déclarer encore différemment
encore du code poubelle
il faut trouver autre chose
dans tout les cas pour les userforms la chose est résolu ça marche du tonnerre et je n'ai même plus d'erreur (grave ou pas)

 

[jurassic pork]

Bon çà m'a l'air de fonctionner qu'avec du IAccessible pour le code de la feuille :

Le code :

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


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
    Dim PosControl As IAccessible
    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
        'Debug.Print PosControl.accRole ' 33 = LIST 46 = COMBOBOX 10 =  CLIENT
        criter = (PosControl.accRole = 33 Or PosControl.accRole = 46)
        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
        ActiveSheet.ScrollArea = control.TopLeftCell.Address 'bloque le scrollarea de la feuille a la cellule la plus proche du control( EVITE LES PETITS SURSAUTS)
        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 Until bLooping = False
End Sub

Le principe :
On utilise la Propriété accRole du IAccessible qui est toujours disponible.
Avec cette propriété on peut savoir si le IAccessible est une liste, une combobox ou un client (quand on est ailleurs dans la feuille)
Il suffit de tester si le iaccessible est une liste ou une combobox pour savoir si on reste dans la boucle.

 

[Dudu2]

Bonjour,
Un petit code de 2 pages et ça gère tout uniquement pour ListBox & ComboBox, exclus les TextBox et autres Controls car j'utilise le .TopIndex, mais c'est suffisant)

 

[patricktoulon]

re
exemplaire de @Dudu2
toujours ce problème de doublage de control

la dernière modif de @jurassic pork
pour la listbox c'est pas fluide mais ca fonctionne
pour la combobox on peut pas la developper car le move lance le do/loop


maintenant un 3 éme version
j'utilise le windowfrompoint pour capter la classe de la fenêtre survolée
@Dudu2 connais ce principe puisqu'on la fait ensemble
l'avantage c'est que pour la combo le mousewheel est actif uniquement dans la fenêtre child de la combo on peut donc developer avec le dropbutton de façon naturelle
et surtout c'est plus fluide

vous savez quoi?
il y a plus de code pour déclarer les api que de code de fonction mousewheel 🤣 🤣

@jurassic pork je vais reprendre l'idée de accrole mais le faire facon a ce que ca se declenche comme dans cette nouvelle version ci joint
ma version avec le windowfrompoint