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

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

patricktoulon

XLDnaute Barbatruc
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
 

Pièces jointes

Solution
Bonjour @jurassic pork , @Dudu2 , @Nathe
j'ai mis le controlrelease en optionnel dans la démo (fonctionne aussi dans userform)
j'en ai profité pour mettre un multipage
et dans la page 1 du multipage j'ai mi un label violet
et c'est lui qui pilote le scroll de la page
comme ca on peut mettre un fond sur chaque page vu que ce control n'a pas de propertie backcolor
bien évidemment j'ai ajouté le textbox
dans cette démo donc on a le controlrelease optionnel
et le scroll piloté par un autre control
voila comme ça on est au même niveau que la V 3.0 avec iaccessible (All control working)

patrick
je redonne le fichier au cas ou avec tout les correctifs Api que je suis en capacité de faire

comme je l'ai dit les apis sont bonnes ,le seul truc dont je doute c'est le remplaçant de copymemory pour le 64 (point api to longlong )
Les déclarations ne sont pas bonnes , il faut mettre les déclarations de fonctions en dernier comme ceci :
VB:
Private WithEvents IC As MSINKAUTLib.InkCollector
Public mycontrol As control
Private Type POINTAPI: X As Long: Y As Long: End Type
#If VBA7 Then
    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
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    #If Win64 Then
        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 Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
    #End If
Mais j'ai toujours le même comportement . J'attend le verdict d'autres testeurs.
 
Dernière édition:
remplace ceci
VB:
       '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

par cela
VB:
Function PointApiToLong(point As POINTAPI) As LongLong
    Dim DbLL As LongLong
    Dim structLong As LongPtr
    structLong = LenB(DbLL)
    If LenB(point) = structLong Then CopyMemory VarPtr(DbLL), VarPtr(point), structLong
    PointApiToLong = DbLL
End Function
sans oublier la declaration de l'api copymemory en 64 et 32
 
remplace ceci
VB:
       '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

par cela
VB:
Function PointApiToLong(point As POINTAPI) As LongLong
    Dim DbLL As LongLong
    Dim structLong As LongPtr
    structLong = LenB(DbLL)
    If LenB(point) = structLong Then CopyMemory VarPtr(DbLL), VarPtr(point), structLong
    PointApiToLong = DbLL
End Function
sans oublier la declaration de l'api copymemory en 64 et 32
Je pense pas que ça va changer grand chose car j'ai un handle qui s'affiche avec l'ancien code et puis j'ai les soucis avec du 32 bits et du 64 bits
 
si tu a le handle qui s'affiche dans le label alors tu pourrais avoir un soucis avec l'api setfocus en 64 bits
en attendant j'ai remplacé
VB:
'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'methode de scrolling de control avec l'object InkCollector
'auteur: patricktoulon
'version:1.0

Private WithEvents IC As MSINKAUTLib.InkCollector
Public mycontrol As control
Private Type POINTAPI: X As Long: Y As Long: End Type
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal point As LongLong) As LongPtr
        Private Declare PtrSafe Sub RtlMoveMemory Lib "kernel32" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length 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

         Private Function PointApiToLong(point As POINTAPI) As LongLong
            Dim DbLL As LongLong
            Dim structLong As LongPtr
            structLong = LenB(DbLL)
            If LenB(point) = structLong Then CopyMemory VarPtr(DbLL), VarPtr(point), structLong
            PointApiToLong = DbLL
        End Function

    #Else
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
     #End If

    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
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As LongPtr) As LongPtr

#Else
    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
    Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
#End If


#If VBA7 Then
Function handlecombo(control) As LongPtr
    Dim class$, handle As LongPtr, Handleparent As LongPtr
#Else
Function handlecombo(control) As Long
    Dim class$, handle As Long, Handleparent As Long
#End If
    Dim pos As POINTAPI, Q&
    GetCursorPos pos
re:
    #If Win64 Then
        handle = WindowFromPoint(PointApiToLong(pos))
    #Else
        handle = WindowFromPoint(pos.X, pos.Y)
    #End If
    class = Space$(255)
    Handleparent = GetParent(handle)
    GetClassName Handleparent, class, 255
    If Q = 0 And Not class Like "F3 MdcPopup*" Then pos.Y = pos.Y + 25: Q = 1: GoTo re

    If class Like "F3 MdcPopup*" Then handlecombo = Handleparent
End Function


    'creation de l'object InkCollertor pour piloter le scroll
    #If VBA7 Then
Private Sub SetupMouseWheel(Ctrl As control, Optional handl As LongPtr = 0)
#Else
Private Sub SetupMouseWheel(Ctrl As control, Optional handl As Long = 0)
#End If
    Set IC = New MSINKAUTLib.InkCollector
    If handl <> 0 Then SetFocus handl Else SetFocus Ctrl.[_GethWnd]
    Set mycontrol = Ctrl
    On Error Resume Next
    With IC
        If handl <> 0 Then .hwnd = handl Else .hwnd = Ctrl.[_GethWnd] ' The InkCollector requires an 'anchor' hWnd
        .SetEventInterest ICEI_MouseWheel, True ' This sets event that you want to listen for
        .MousePointer = IMP_Arrow ' If this is not set, the mouse pointer disappears
        .DynamicRendering = False ' I suggest turning this off
        .DefaultDrawingAttributes.Transparency = 255 ' And making the drawing fullly transparent
        .Enabled = True ' This must be set last
    End With
End Sub

Private Sub UserForm_Activate()
    ListBox1.List = Evaluate("row(1:30)")
    ComboBox1.List = Evaluate("row(1:30)")
End Sub

Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'stop the scrolling when you leaves control
    ' destruction of object IC
    Set IC = Nothing
    'THE DESTRUCTION OF THE OBJECT ic IN THE MOVE OF THE USERFORM IS TEMPORARY. I WILL ADD MY RECTANGLE FUNCTIONS TO IT SO THAT IT IS AUTOMATIC.

End Sub


Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SetupMouseWheel Frame1
End Sub

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

Private Sub MultiPage1_MouseMove(ByVal Index As Long, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    SetupMouseWheel MultiPage1
End Sub

Private Sub ComboBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    #If VBA7 Then
        Dim h As LongPtr
    #Else
        Dim h As Long
    #End If
    h = handlecombo(ComboBox1)
    Label2.Caption = "combobox1" & vbCrLf & " handle : " & h
    If h <> 0 Then
        SetupMouseWheel ComboBox1, h
    End If
End Sub

Private Sub IC_MouseWheel(ByVal Button As MSINKAUTLib.InkMouseButton, ByVal Shift As MSINKAUTLib.InkShiftKeyModifierFlags, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    Select Case True
        Case TypeOf mycontrol Is Frame
            CallByName mycontrol, "ScrollTop", VbLet, IIf(Delta > 0, Application.Max(mycontrol.ScrollTop - 8, 0), mycontrol.ScrollTop + 8)
            
        Case TypeName(mycontrol) = "ListBox" Or TypeOf mycontrol Is ComboBox
            CallByName mycontrol, "TopIndex", VbLet, IIf(Delta > 0, Application.Max(mycontrol.TopIndex - 1, 0), mycontrol.TopIndex + 1)
            
        Case TypeOf mycontrol Is MultiPage
            CallByName mycontrol.Pages(mycontrol.Value), "ScrollTop", VbLet, IIf(Delta > 0, _
                                                          Application.Max(mycontrol.Pages(mycontrol.Value).ScrollTop - 8, 0), _
                                                          mycontrol.Pages(mycontrol.Value).ScrollTop + 8)
            
    End Select
End Sub

après je ne vois pas ce que ça peut être
 
Bon j'ai regardé, j'ai tenté de changer quelques lignes qui ne me paraissait pas en adéquation :
  • Dans la fonction handlecombo j'ai viré la paramètre control qui n'était pas utilisé.
  • Fait d'autres tests mais non probant.
J'ai bien le Handle afficher pour le combobox.
000100.png

Ce qui est sûr c'est que pour les contrôles ComboBox1 et Multipage1, cela ne déclenche pas la procédure IC_MouseWheel
 
re
je l'ai mis la déclaration ,me semble t il dans le correctif
c'est une énigme
mettez un msgbox ou debug.print au debut de l'event pour voir si l'event est effectif
et je viens d'apprendre que l'api setfocus aurait des soucis en 64 bits
d'autre par le scroll est effectué par callbyname control, property,delta
peut être qu'en 64 ca va pas il faudrait essayer avec l'autre méthode
mais essayez le message avant
si vous avez le message c'est que la prise en charge du mousewheel est effective et ça confirmerait le problème avec callbyname
 
j'ai mis un Debug.Print en début de IC_MouseWheel comme ceci :
VB:
Private Sub IC_MouseWheel(ByVal Button As MSINKAUTLib.InkMouseButton, ByVal Shift As MSINKAUTLib.InkShiftKeyModifierFlags, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    Debug.Print "MouseWheel"
    Select Case True
        Case TypeOf mycontrol Is Frame
            CallByName mycontrol, "ScrollTop", VbLet, IIf(Delta > 0, Application.Max(mycontrol.ScrollTop - 8, 0), mycontrol.ScrollTop + 8)
            
        Case TypeName(mycontrol) = "ListBox" Or TypeOf mycontrol Is ComboBox
            CallByName mycontrol, "TopIndex", VbLet, IIf(Delta > 0, Application.Max(mycontrol.TopIndex - 1, 0), mycontrol.TopIndex + 1)
            
        Case TypeOf mycontrol Is MultiPage
               CallByName mycontrol.Pages(mycontrol.Value), "ScrollTop", VbLet, IIf(Delta > 0, _
                                                          Application.Max(mycontrol.Pages(mycontrol.Value).ScrollTop - 8, 0), _
                                                          mycontrol.Pages(mycontrol.Value).ScrollTop + 8)
            
    End Select
End Sub

Quand c'est la ComboBox pas de MouseWheel
 
ok change l'events pour celui là
VB:
Private Sub IC_MouseWheel(ByVal Button As MSINKAUTLib.InkMouseButton, ByVal Shift As MSINKAUTLib.InkShiftKeyModifierFlags, ByVal Delta As Long, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)
    vue Delta
    Select Case TypeName(mycontrol)
        Case "Frame"
            If Delta > 0& Then
                mycontrol.ScrollTop = Application.Max(mycontrol.ScrollTop - (8), 0)
            Else
                mycontrol.ScrollTop = Application.Min(mycontrol.ScrollTop + (8), mycontrol.ScrollHeight)
            End If
        Case "MultiPage"
            If Delta > 0& Then
                mycontrol.Pages(mycontrol.Value).ScrollTop = Application.Max(mycontrol.Pages(mycontrol.Value).ScrollTop - (8), 0)
            Else
                mycontrol.Pages(mycontrol.Value).ScrollTop = Application.Min(mycontrol.Pages(mycontrol.Value).ScrollTop + (8), mycontrol.Pages(mycontrol.Value).ScrollHeight)
            End If
     Case "ListBox", "ComboBox"
            On Error Resume Next
            If Delta > 0& Then
                mycontrol.TopIndex = Application.Max(mycontrol.TopIndex - (1), 0)
            Else
                mycontrol.TopIndex = Application.Min(mycontrol.TopIndex + (1), mycontrol.ListCount - 1)
            End If
              
    End Select
End Sub
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

P
Réponses
1
Affichages
834
P
Retour