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]

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 :

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.

 

[patricktoulon]

remplace ceci

       '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

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

 

[jurassic pork]

remplace ceci

       '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

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

 

[patricktoulon]

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é

'*****************************************************************************************************
'    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
'   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
'  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
'//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
'****************************************************************************************************
'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

 

[Valtrase]

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.

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

 

[patricktoulon]

@Valtrase
pourtant

 

[patricktoulon]

heu juste une question
regardez bien dans les références si vous avez la ref 🙁Microsoft Tablet PC Type Library).) d'activée
peut ^tre que le nom est un peu différent sur 64 bits ou tout simplement absente ou dll non enregistrée

 

[Valtrase]

regardez bien dans les références si vous avez la ref Microsoft Tablet PC Type Library).) d'activée

Heu j'ai peu-être oublié la déclaration de copymemory, 🙄 je regarde...

 

[patricktoulon]

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

 

[Valtrase]

je l'ai mis la déclaration ,me semble t il dans le correctif

Non je ne pense pas.

 

[jurassic pork]

j'ai mis un Debug.Print en début de IC_MouseWheel comme ceci :

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

 

[patricktoulon]

donc le handle que tu capte est sans doute celui du userform, ca veut dire que windowfrompoint et la conversion point to longlong fonctionnent mal

dans cette exemple j'affiche la classe tu dois avoir "F3 mdcPoPup xxx..."
comme ça tu le vois tout de suite si c'est bon ou pas

 

[Valtrase]

Toujours pareil... C'est fou ça.
Sur survol de la liste déroulante :

Et maintenant après le clic sur le Dropdown

Pour les contrôles Liste déroulante et Multipage la procédure IC_MouseWheel n'est jamais exécutée...

 

[patricktoulon]

re oui tout est bon mais ça marche pas c'est vraiment un truc de fous je vais tenter autre chose
je reviens

 

[patricktoulon]

ok change l'events pour celui là

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