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

 

[jurassic pork]

Hello,
Patricktoulon a oublié de s'intéresser au Post #40 de ChTi160 (car il est parti sur autre chose 😉).
Effectivement il y avait une erreur : on ne remontait pas jusqu'à la première ligne pour la ComboBox et la ListBox :
Il y avait une autre erreur pour une frame.
Dans le code de la procédure MouseWheel corrigé j'ai indiqué où j'ai changé quelque chose

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

Ami calmant, J.P

 

[ChTi160]

Bonjour le Fil
tout d'abord merci a J.P !
j'ai un petit problème lorsque je veux utiliser la méthode de J.P

j'utilisais la version "MouseWheelOut" de Patrick;
si je change de procédure pour utiliser celle de J.P il me manque "AccessibleObjectFromPoint" comment puis je faire ,
pour adapter la Procédure de Patrick , ou faire autrement ?
Merci par avance
Bonne Journée
Jean marie

 

[jurassic pork]

si je change de procédure pour utiliser celle de J.P il me manque "AccessibleObjectFromPoint"

Hello ChTi160,
c'est à dire ? elle est bien déclarée au début du code du formulaire ? ton code est dans un formulaire ou dans un module ?
Ami calmant, J.P

 

[ChTi160]

Re
la procédure de Patrick "Sub MouseWheelOut(control As Object, Optional yy As Single = 0, Optional pilote As Object = Nothing)" devait être dans un Module. je l'utilise avec des Controls de Userform !
je n'avais donc pas la procédure "AccessibleObjectFromPoint"
merci
Jean marie

 

[jurassic pork]

la procédure de Patrick "Sub MouseWheelOut(control As Object, Optional yy As Single = 0, Optional pilote As Object = Nothing)" devait être dans un Module. je l'utilise avec des Controls de Userform !

Dans ton module il faut que tu mettes les déclarations comme dans le code du formulaire IAccessible de démo c'est à dire :

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

 

[ChTi160]

Re
j'utilisais les procédures de Patrick et tout fonctionnait , sauf cette histoire de Première Ligne que je n'arrive pas a afficher !
il me faut si je comprends bien tout supprimer de ces Procédure et les remplacer par celles des post #46 et #50 , c'est ça ?
Merci
jean marie

 

[Piment]

Jurassic pork, Jean-Marie, bonjour,
Je suis le fil depuis ce matin. En ce qui me concerne, j'ai copié le module "Modul_MouseWhel" de Patrick dans mon fichier, et mes comboBox fonctionnent correctement.
Effectivement, cela ne remontais pas à la première ligne.
Suite au post de jurtassic pork, j'ai modifié la ligne "control.TopIndex = Application.Max(control.TopIndex - 1, 0)". J'ai donc mis 0, et apparemment cela fonctionne: ma première ligne remonte bien maintenant.
Modification dans "Case "listbox,c "comboBox".

 

[ChTi160]

re
Bonjour jacques
les procédures et Emplacement de ce que j'utilisais
Dans le code du Userform j’ai ces Procédures :

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

Et dans mon Module Standard « Mdl_MouseWhell » :

 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

Et

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

Et

 ' 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

je regarde la modification de Piment
jean marie

 

[ChTi160]

Re
Effectivement ça Fonctionne , j'attends les réactions de Patrick et J.P !
merci Jacques !
Jean marie

 

[patricktoulon]

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 ballo
pour les feuille je suis donc repasser en mode rectangle avec le y du move sur la combo
et pour le coup j'ai séparé le message souris du scroll
donc voici la version 2.0 en prepa
c'est brouillon encore je cherche un bon moyen de brider ça

 

[jurassic pork]

1753]@jurassic pork[/USER] 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 ballo

J'ai regardé avec FlaUInspect avec un activeX ComboBox et un ListBox dans une feuille , il n'y a que le ListBox qui est en objet , les autres activeX sont dans le panneau de la feuille et sous forme d'Images :

et quand on est en mode Création dans la feuille, la liste n'est plus là.
Ami calmant, J.P

 

[patricktoulon]

re
@jurassic pork oui c'est pour ça que sur la feuille je repasse en rectangle
mais je n'arrive pas bien a stabiliser le processus pour la combobox

 

[jurassic pork]

re
@jurassic pork oui c'est pour ça que sur la feuille je repasse en rectangle
mais je n'arrive pas bien a stabiliser le processus pour la combobox

T'attarde pas trop sur ce sujet car les gens utilisent certainement plutôt la liste de la validation de données qui est équivalente à une combobox.

 

[Rheeem]

Bonjour;

Je n'ai pas de souris j'utilise un laptop :

Essayer ces API windows pour contrôler le défilement pour le combo et pour d'autres contrôles ,,certes que ces controles n'ont pâs la propriété handle mais le message sera retransmit du parent vers le controle
GetCursorPos Pt
HWindow = WindowFromPoint(Pt)
PostMessage(HWindow, WM_VSCROLL, SB_LINEUP,0)
ou
PostMessage(HWindow, WM_VSCROLL, SB_LINEDOWN,0)

 

[ChTi160]

Bonjour Rheeem
Aurais tu un fichier exemple, où tu mets en pratique cette méthode ?
Merci par avance
Jean marie