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]

En gardant le Handle initial pour déterminer si on quitte le Control, ça donne ça.
Chez moi ça marche. J'ai modifié mon système de boucle pour me caler sur le tien en espérant la fin des doubles ListBox... SInon....

Pour les TextBox ça a tout cassé, faut revoir, mais ça va pas être simple.

 

[patricktoulon]

perso je vois pas pourquoi tu va chercher midi 14 heures
c'est pourtant simple on veut les classe F3 server xxxxxxx et F3 MdcPopuP xxxxxxx
les frame, listbox,multipage = classe F3 server xxxxxxx
les combo F3 mdc xxxxxxxxx
donc
si je suis dessus ca déclenche et si ça déclenche control+ bonne classe = ok
c'est arrêté et relancé a chaque changement de control
et si pas control ou pas ok(isscrollable=false) arret jusqu'au prochain survol(lancé par les event mousemove)
qui donne une classe en cohérence avec le control
c'est pas compliqué a comprendre

je pense que tu n'a pas bien compris le principe

 

[patricktoulon]

re

 

[Dudu2]

perso je vois pas pourquoi tu va chercher midi 14 heures

C'est comme tu le sens.

je pense que tu n'a pas bien compris le principe

Çà doit être ça, surtout si je pointe un défaut de ton code (toujours présent dans ta dernière version) c'est que j'ai pas compris .
J'adore ta façon de prendre les gens pour des imbéciles.

Fais comme moi comme ici (en gardant le Handle initial pour déterminer si on quitte le Control) et ça fonctionnera.
Si tu as compris le problème

.

 

[patricktoulon]

re
ce que tu montre avec les control collés ne se fait pas chez moi
pour la simple et bonne raison

  If ActualControl Is control Then Exit Sub
      Set ActualControl = control

chez moi actualcontrol et control est bien différencié
si actualcontrol est le control alors l'appel du move est annulé par le exit (on reste donc dans le precedent do/loop
si cette ligne est passée sans exit alors actualcontrol devient le control survolé
il est donc impossible que ca reste sur l'ancien control (sauf chez dudu)

encore une fois tu crois que ce qui se passe chez toi c'est ce qui se passe partout

quand est ce que tu va comprendre qu'il y a quelque chose qui va pas dans ton system
entre les controls qui se double une simple condition sur 2 object (actualcontrol/control)qui ne fonctionne pas
et j'en passe et des meilleures je ne te prends pas pour un imbécile c'est toi qui n’écoute pas
et là ma capture te le prouve encore une fois
mais je parle dans le vide de toute façon je le sais
et là il ne s'agit pas d'api ou quoi qu'est ce
c'est simplement le move qui injecte l'object

Private Sub ListBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SheetMouseWheel ListBox2
End Sub

Private Sub ListBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SheetMouseWheel ListBox1
End Sub

Sub SheetMouseWheel(control As Object)
    'MESSAGE SOURIS POUR LES CONTROLS DANS FEUILLE
    Const WM_MOUSEWHEEL = &H20A, PM_NOREMOVE = &H0&
    Dim tMsg As Msg, ldelta As Integer, pos As POINTAPI, criter As Boolean, rc As Rect, OnSheet As Boolean
      If ActualControl Is control Then Exit Sub
      Set ActualControl = control
      '...
      '...
      '...'

un truc aussi simple que ça ne fonctionne pas correctement chez toi
pose toi les bonnes questions @Dudu2 P... de Manon

tu le vois en haut a droite en rouge ou je te prête mes lunettes

 

[patricktoulon]

après si tu veux faire avec rectangle c'est ton droit mais ne dis pas que mon switch control ne fonctionne pas
il ne fonctionne pas chez toi et que chez toi
tout le monde la testé et ça fonctionne donc .......
et perso le rectangle j'ai pas besoins des api

 

[Dudu2]

C'est parce que tu as mis le Scroll sur la ListBox2.
Si tu ne le mets pas ça ne fonctionne pas comme tu le montres.
Si ListBox2 n'a pas besoin de Scroll (petite listBox) ou si c'est une Combo (petite Combo) ou Page ou un Frame qui n'a pas besoin de Scroll, on ne met pas le Scroll sur le Control.
De toutes façons, le simple fait que dans certains cas ça ne fonctionne pas prouve que le mécanisme n'est pas 100% fiable.

Après tu fais comme tu veux, moi je fais différemment.

 

[Dudu2]

Autre exemple...

 

[jurassic pork]

Hello,
Patrick dans le classeur du post #183 il y a une erreur pour la Sub ss
D'autre part on peut se passer entièrement de copyMemory en utilisant un autre code pour HIWORD.
Voici la partie déclaration complète avec le nouveau code :

Option Explicit
Public looping As Boolean
Public ActualControl As Object
Public holdarea$
Public py&
Private Type POINTAPI: X As Long: Y As Long: End Type
Type Rect: left As Long: top As Long: right As Long: bottom As Long: End Type
#If VBA7 Then
    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 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 Declare PtrSafe Function GetParent Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    #If Win64 Then
        Private Const NULL_PTR = 0
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
        Private Type t8: L As LongLong: End Type
        Private Function PointApiToLong(point As POINTAPI) As LongLong
            Dim t As t8
            LSet t = point
            PointApiToLong = t.L
        End Function
    #Else
        Private Const NULL_PTR = 0&
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
        Private Function HIWORD(ByVal LongIn As LongPtr) As Integer
            On Error Resume Next
            HIWORD = (CLng(LongIn) And (&HFFFF0000)) \ (&H10000)
            On Error GoTo 0
        End Function  
#Else
    Private Type Msg: hWnd As Long: message As Long: wParam As Long: lParam As Long: time As Long: pt As POINTAPI: End Type
    Private Const NULL_PTR = 0&
    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 Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) 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
    Private Function HIWORD(ByVal LongIn As Long) As Integer
        HIWORD = (LongIn And (&HFFFF0000)) \ (&H10000)
    End Function
#End If
'************************************************************************************************************************
'************************************************************************************************************************
Sub ss(): Set ActualControl = Nothing: End Sub 'ce n'est pas ActiveControl mais ActualControl

Explication de pourquoi il y a un On Error Resume Next dans la fonction HIWORD :
Quand on est en 64 bits LongPtr est un LongLong (64 bits) le CLng(LongIn) permet de ramener le LongLong à un Long (32 bits) en tronquant (pas d'impact normalement) mais le souci c'est que le LongLong peut être négatif et cela amène un dépassement de capacité pour le CLng
En tout cas j'ai testé le code ci-dessus en Excel 2007, Excel 2016 32 bits , Excel2021 64 bits Tout semble fonctionner correctement, les scrolls sont fluides.
Ami calmant, J.P

 

[ChTi160]

Bonjour le Fil
bon Après test , chez moi aussi si Une seule ListBox est traitée et quelles sont très proches , alors j'ai le même phénomène que dudu
Bonne Journée
Jean marie

 

[Nathe]

Bonjours tout le monde,
test du post #183

Nathe

 

[jurassic pork]

Bonjours tout le monde,
test du post #183
Nathe

Hello Nathe,
ce phénomène, je l'ai aussi dans un nouveau classeur dans lequel j'insère un contrôle ActiveX ListBox :

Ami calmant, J.P

 

[patricktoulon]

allez le enter dans combobox encore plus simple et propre
l'astuce est simple en entrée je test pos.y+ la largeur de la combo pour tomber dans la child
si elle est developpée criter sera ok sinon non
par contre dans le do/loop je test juste pos.x et pos.y puisque je suis dedans déjà
voila c'est propre
et j'ai ajouté le releaseControl qui replis la combo quand on en sort
testé sur
2013 32 bits sur W10
2016 64 bits sur W 10

 

[patricktoulon]

Bonjour @jurassic pork
ok je vais regardé mais j'ai ajouté des choses dans la version windowfrompoint
entre autres le release control pour replier la combo dans les userforms quand on en sort
apres ca reste un truc pour dire de ne pas jeter car pour ma part la version IAccessible est beaucoup plus performante
il faudrait ajouter le decalage au premier test isscrollable comme dans cette version pour avoir le croll en entrée des que c'est developpé

@Dudu2 a ben oui forcement si tu colle 2 listboxs dont une n'a pas l'event et encore je suis pas sur je vais tester

 

[Dudu2]

@Dudu2 a ben oui forcement si tu colle 2 listboxs dont une n'a pas l'event et encore je suis pas sur je vais tester

La ListBox c'était par facilité de recopie. Regarde le Post #188.

C'est pourtant facile à régler. Je l'ai déjà dit.
Tester Le ClassName du Parent ce n'est pas fiable pour savoir si on est toujours dans le Control.
Il faut capturer le Handle du control au tout début et le comparer à chaque fois avec celui qu'on récupère du WindowFromPoint dans la boucle.