Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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
Hello,
j'ai un peu bossé sur le InkCollector. Je ne sais pas si c'est très intéressant mais on peut définir un InkCollector par Controle (à voir si on ne peut pas utiliser une collection de InkCollector).
Voici par un exemple pour un userform qui a une Frame, une ListBox et une Combobox :
VB:
Private WithEvents IC1 As MSINKAUTLib.InkCollector
Private WithEvents IC2 As MSINKAUTLib.InkCollector
Private WithEvents IC3 As MSINKAUTLib.InkCollector

Private Sub UserForm_Activate()
    Set IC1 = New MSINKAUTLib.InkCollector
    Set IC2 = New MSINKAUTLib.InkCollector
    ' Set IC3 = New MSINKAUTLib.InkCollector
    SetupMouseWheel Frame1, IC1
    SetupMouseWheel ListBox1, IC2
   ' SetupMouseWheel ComboBox1 pas faisable pas de handle
End Sub

Private Sub SetupMouseWheel(Ctrl As control, InkCol As MSINKAUTLib.InkCollector)
    With InkCol
        .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 IC1_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)
            If Delta > 0 Then
                Frame1.ScrollTop = Application.Max(0, Frame1.ScrollTop - 5)
            Else
                Frame1.ScrollTop = Application.Min(Frame1.ScrollHeight, Frame1.ScrollTop + 5)
            End If
End Sub
Private Sub IC2_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)
            If Delta > 0 Then
                ListBox1.TopIndex = Application.Max(ListBox1.TopIndex - 1, 0)
            Else
                ListBox1.TopIndex = Application.Min(ListBox1.TopIndex + 1, ListBox1.ListCount - 1)
            End If
End Sub
Private Sub IC3_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)
            If Delta > 0 Then
                ComboBox1.TopIndex = Application.Max(ComboBox1.TopIndex - 1, 0)
            Else
                ComboBox1.TopIndex = Application.Min(ComboBox1.TopIndex + 1, ComboBox1.ListCount - 1)
            End If
End Sub

On crée les InkCollector à l'activation du formulaire et ils restent actifs tout le temps :
Voici ce que cela donne ;


Apparemment le scroll est bien géré suivant où on est.

En ce qui concerne la ComboBox, voici une animation qui montre où est le problème :



En fait ce que l'on doit scroller dans une Combobox, c'est une ListBox popup qui est créée seulement quand on clique sur le bouton de la ComboBox et cette popup est détruite dès qu'on sélectionne un élément.
Il faudrait donc créer le Inkcollector au moment où apparait la popup avec comme hwnd le handle de la popup.

Ami calmant, J.P
 
re Bonjour @jurrassic pork
je vais regarder ça
mais moi je crée le Ink et le détruit en sortant du control
pour le handle de la popup j'ai mis ma petite fonction et surtout comme pour les autres control je lui donne le focus avec l'api du même nom
et çà marche
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
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


Function handlecombo(control) As Long
    Dim class$, handle As LongPtr, Handleparent As LongPtr, 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
Private Sub SetupMouseWheel(Ctrl As control, Optional handl As Long = 0)
    Set IC = New MSINKAUTLib.InkCollector
    If handl <> 0 Then SetFocus handl Else Ctrl.SetFocus
    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
    'provisoire  je vais lui ajouter la fonction rectangle sans api pour sortir
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)
    Dim h As LongPtr
    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
 

Pièces jointes

Hello patricktoulon
chez moi en Excel 2016 32 bits avec ton classeur, la ComboBox et le Multipage ne fonctionnent pas (pas de scroll avec la molette souris dans ces contrôles)
 
re
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 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

    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 PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
 Private Declare PtrSafe 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 Ctrl.SetFocus
    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
attention le multipage il faut selectionner l'onglet page même si c'est celui affiché
 
Dernière édition:
non non chez moi cela ne fonctionne pas (windows 11) et toi tu testes avec quelle version d'excel et quel O.S
 
Bonjour à tous,
Ma config pour le test : Windows 10 64bits et Office 365 32bits.
Hello patricktoulon
chez moi en Excel 2016 32 bits avec ton classeur, la ComboBox et le Multipage ne fonctionnent pas (pas de scroll avec la molette souris dans ces contrôles)
Idem pour moi,
attention le multipage il faut selectionner l'onglet page même si c'est celui affiché
Pas glop du tout même en sélectionnant la page. 🙄
 
et j'ai trouvé le moyen de ne pas avoir a sélectionner l'onglet dans le multipage
en fait je donne le focus au handle de la child de la combo ou au control pour les autre controls
en fait il faut donner le focuas au handle sans faire un "CtrL.Setfocus"
donc je corrige la ligne dans la setupMouseWhell
VB:
 If handl <> 0 Then SetFocus handl Else SetFocus Ctrl.[_GethWnd]
c'est @Valtrase qui va être content et glop 🤣

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 )
 

Pièces jointes

Dernière édition:
- 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
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…