XL 2019 Molette Scroll sur ListBox

[gg13]

Bonjour,

Je commence un nouveau projet pour lequel je devrai utiliser des ListBox et ComboBox.
Ces listes seront longues et je voudrais utiliser le scroll de la molette plutôt que les ascenseurs.

Après renseignement sur le site j’ai voulu utiliser ce post :
Mouse Wheel Hook (faire défiler le contenu d'une combobox/listbox avec la roulette)

Je galère depuis 2 jours et malgré plusieurs essais je n’arrive pas à intégrer ces différentes macros, plusieurs messages d’erreurs ….
Je ne comprends pas tout.
Si vous pouvez m’aider un peu je vous remercie d’avance.

Je joins le fichier exemple avec les listBox .

GG13

 

[Dudu2]

Ceci dit, je peux virer le Timer qui régule mais n'apporte pas de protection particulière.

 

[patricktoulon]

Gestion du WM_MOUSEMOVE:
Tu n'interceptes pas les mouvements de la souris alors que pour moi c'est là que je édtermine si oui ou non la souris est sur le Control.
De mon point de vue, le faire sur un WM_MOUSEWHEEL uniquement c'est trop tard. On peut être complètement ailleurs.

et oui c'est la ou je vois que tu n'a pas compris comment ca fonctionne

une fois qu'elle est enclenchée il n'y a que le bool qui l'arrête

et si tu n'avais pas lu en diagonal mes commentaires tu aurais vu que je fait d'office le test overbox
regarde mieux fait moi plaisir

et j'insiste aussi sur le fait de OU JE MET LE CALLBACK
j'attends pas de gérer plus ou moins bien une erreur quelconque qui pourrait arriver et unhooker avant la gestion ce qui fait que le callback serait jamais rappelé

Gestion de l'erreur sur .TopIndex:
Il faut la capter et UnHooker.

et pourquoi voudrais tu que ça ne le soit pas
si il y a une erreur la gestion global va être enclenché
le on error goto gestion_d_erreur est valable de la première à la dernière ligne de code
comme le callback est annoncé elle peut tourner tourner elle atterrira toujours là
elle ne sortira que par Bool
en toute transparence

regarde

regarde des que je suis entré dans le controls et que je bouge que je scroll ou danse sur la tête
quelque soit le message de la souris l'effetest là et cela sans le WM_MOUSEMOVE
regarde bien la cellule C1 je met un nombre au hasard a chaque message
tu vois tu n'en a pas besoins
c'est absolument inutile tout tes gestions d'erreur

FINALEMENT
on a besoin de quoi????????
d'intercepter le message de la molette de la souris c'est tout
1 on gere les erreur globalement
2 on relance le callback au mouse well pour qu'elle reparte au prochain message
3 la dessus on fait un control rectangle (checkoverbox )
bool=oui ou non
si oui ben scroll sinon unhook ou l'inverse comme tu veux
gestion d'erreur (NIMPORTE QUELLE ERREUR) on relance un nexthook
et c'est terminé

c'est d'une simplicité

 

[patricktoulon]

regarde pour te dire a quel point tu t ennuie pour rien
je vais prendre ma version de la fonction de mon fichier
et je vais y mettre ton test bool(checkovertrucmachin chouete) et ca va marcher pareil

'Molette souris  Up/Down Listbox , ComboBox , Frame
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim pos As POINTAPI, obj As Object, r As Range, CtL
    Dim Bool
    On Error Resume Next
    GetCursorPos pos
    'je bloque mon test rectangle
    'If pos.Y < rct2.Top Or pos.Y > rct2.Bottom Or pos.X < rct2.Left Or pos.X > rct2.Right Then UnHookMouse: Exit Function

    'je met le tiens
CheckMouseIsOverTheBox:
    Bool = MouseIsOverTheBox
    If Not Bool Then
        Call UnHookMouse: Exit Function
    End If


    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            'et c'est ici que vous avez un probleme sur 64 vec le delay
            With ControlHooked
                Select Case TypeName(ControlHooked)    ' déplace l'ascenseur en fonction de la molette ' l'info est stockée dans lParam
                Case "ListBox", "ComboBox": If GetHookStruct(lParam).mouseData > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
                Case "Frame": If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 3 Else .ScrollTop = .ScrollTop + 3
                End Select
            End With
        End If
        Exit Function
    End If
    'partie gestion d'erreur
    DoEvents: Debug.Print Err.Number
    On Error GoTo 0
    
    'LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
End Function

démonstration

 

[Dudu2]

on a besoin de quoi???????? d'intercepter le message de la molette de la souris c'est tout

Non, ça sert à rien de récupérer la position de la souris sur un MOUSEWHEEL.
La souris ne change de position QUE sur un MOUSEMOVE.
C'est pour cette raison que j'utilise le MOUSEMOVE.

on gere les erreur globalement

Ce n'est pas suffisant. Sur une erreur de .TopIndex il faut UnHooker. C'est pas suffisant de faire Resume Next.

Ce code est d'une simplicité enfantine. Mais faire simple, c'est plus compliqué que de faire compliqué.

Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim Obj As Object
    Dim DoNotCallNextHook As Boolean

    'Prevent Excel crash (e.g. Alt+F4 on UserForm with Hooked Control)
    On Error Resume Next
  
    'Test validité du ControlHooked
    Set Obj = ControlHooked
  
    'Le ControlHooked a disparu ?
    If Err.Number <> 0 Or Obj Is Nothing Then
        Err.Clear
        Call UnHookMouse
    Else
        If nCode = HC_ACTION Then
            If wParam = WM_MOUSEMOVE Then
                'Check if the mouse is still on the Control
                If Not MouseIsOverTheBox Then
                    Call UnHookMouse
                End If
            End If
          
            If wParam = WM_MOUSEWHEEL Then
                DoNotCallNextHook = True
              
                With ControlHooked
                    'Is the Window still there (.TopIndex in error) ?
                    Err.Clear
                  
                    'Moves the ScrollBar depending on the mouse wheel, Info is stored in lParam
                    If GetHookStruct(lParam).mouseData > 0 Then
                        If .TopIndex < ScrollStep Then .TopIndex = 0 Else .TopIndex = .TopIndex - ScrollStep
                    Else
                        .TopIndex = .TopIndex + ScrollStep
                    End If
                  
                    'Is the Window still there (.TopIndex in error) ?
                    If Err.Number <> 0 Then
                        Err.Clear
                        Call UnHookMouse
                        Exit Function
                    End If
                End With
            End If
        End If
    End If

    If Not DoNotCallNextHook Then
        LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    Else
        LowLevelMouseProc = True
    End If

    On Error GoTo 0
End Function

 

[patricktoulon]

1° je ne fait pas un on erreur resume next avec ta fonction

2°je fait un on error goto gestion_d_erreur
c'est loin d'être la même chose

3°et je ne récupère pas le box over au mouse well je le récupère tout court


4° le topindex va déclencher une erreur si =0 et molette vers le haut
ben que cela te tienne là encore c'est l’étiquette gestion_d_erreur qui va être sollicitée


tu lis en diagonale

je te l'ai dis prends le temps de me lire

 

[Dudu2]

J'ai bien vu les différences. Mais qu'est-ce que tu veux au juste ? Que je mette ton code à la place du mien ?
NON ! J'ai fais mon code, il me plait et je n'aime pas le GOTO.

Et pourquoi tu ne mettrais mon code à la place du tien ? Après tout je pourrais aussi te harceler pour faire ça ? Et d'ailleurs je vais le faire... Pourquoi tu n'utilises pas mon code à la fin ?

Si tu veux utiliser ton code dans tes programmes personne ne t'en empêche et surtout pas moi.
Qu'est-ce que c'est que cette insistance ?

 

[patricktoulon]

je n'insiste pas sur ton code ou le mien
je te dis seulement que tu en fait beaucoup pour rien
a quoi sert de faire 36 gestions d'erreur qui t'amèneront au même endroit
c'est a dire peut être un unhook et reprise si toujours dans le controls
tu n'aime pas les goto OK mais les gosub( il me semble en avoir vu un) c'est pareil

a près tu a raison tu fait comme tu veux

 

[Dudu2]

Je fais des gestions d'erreurs discriminées pour prendre l'action adaptée et aussi savoir plus tard, en relecture du code, ce qui peut se passer sur chaque élément qui peut partir en erreur.

 

[patricktoulon]

tiens après j'arrête parce que tu comprends pas
ça c'est ton code
j'ai bloqué des lignes et je commente
dis moi que j'ai tords

Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim Obj As Object
    Dim DoNotCallNextHook As Boolean

    'Prevent Excel crash (e.g. Alt+F4 on UserForm with Hooked Control)
    On Error Resume Next
 
    'Test validité du ControlHooked
    Set Obj = ControlHooked
 
    'Le ControlHooked a disparu ?
    If Err.Number <> 0 Or Obj Is Nothing Then
        Err.Clear
        Call UnHookMouse
    Else
        If nCode = HC_ACTION Then
            '!!!! et pourquoi attendre de bouger la souris pour savoir si on est dedans  le control
            '!!!je peux tres bien rester immobile et ne toucher que la mollette
            '!!!!au quel cas cette condition passera inapercue
            'If wParam = WM_MOUSEMOVE Then
                'Check if the mouse is still on the Control
                If Not MouseIsOverTheBox Then
                    Call UnHookMouse
                End If
            'End If
         
            If wParam = WM_MOUSEWHEEL Then
                DoNotCallNextHook = True
             
                With ControlHooked
                    'Is the Window still there (.TopIndex in error) ?
                    Err.Clear
                 
                    'Moves the ScrollBar depending on the mouse wheel, Info is stored in lParam
                    If GetHookStruct(lParam).mouseData > 0 Then
                        If .TopIndex < ScrollStep Then .TopIndex = 0 Else .TopIndex = .TopIndex - ScrollStep
                    Else
                        '!!!!!on fait pareil que a fait pour le "-" mais l'inverse
                        If .TopIndex < .ListCount - ScrollStep Then .TopIndex = .TopIndex + ScrollStep
                    End If
                 
                    '!!!!!!!on peut donc supprimer toute cette gestion d'erreur
                    'Is the Window still there (.TopIndex in error) ?
                    'If Err.Number <> 0 Then
                       ' Err.Clear
                        'Call UnHookMouse
                        'Exit Function
                    'End If
                End With
            End If
        End If
    End If

    If Not DoNotCallNextHook Then
        LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    Else
        LowLevelMouseProc = True
    End If

    On Error GoTo 0
End Function

 

[Dudu2]

tiens après j'arrête parce que tu comprends pas
ça c'est ton code
j'ai bloqué des lignes et je commente
dis moi que j'ai tords

'Molette souris  Up/Down Listbox , ComboBox , Frame
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim pos As POINTAPI, obj As Object, r As Range, CtL
    Dim Bool
    
    '!!!! Gestion d'erreur généraliste
    '!!!! Couvre les erreurs générales et ignore les traitements particuliers nécessaires
    '!!!! Si le .TopIndex se plante il n'y a pas de UnHook, c'est juste Resume Next !!!!
    '!!!! Si le Control Hooked a disparu pour une raison ou une autre il n'y a pas de UnHook, c'est juste Resume Next !!!!
    '
    On Error Resume Next
    GetCursorPos pos
    'je bloque mon test rectangle
    'If pos.Y < rct2.Top Or pos.Y > rct2.Bottom Or pos.X < rct2.Left Or pos.X > rct2.Right Then UnHookMouse: Exit Function

    'je met le tiens
CheckMouseIsOverTheBox:

    '!!!! Pourquoi lancer la fonction lorsque c'est un WM_MOUSEWHEEL
    '!!!! Ça sert strictement à rien
    '
    Bool = MouseIsOverTheBox
    If Not Bool Then
        Call UnHookMouse: Exit Function
    End If


    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            'et c'est ici que vous avez un probleme sur 64 vec le delay
            With ControlHooked
                Select Case TypeName(ControlHooked)    ' déplace l'ascenseur en fonction de la molette ' l'info est stockée dans lParam
                Case "ListBox", "ComboBox": If GetHookStruct(lParam).mouseData > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
                Case "Frame": If GetHookStruct(lParam).mouseData > 0 Then .ScrollTop = .ScrollTop - 3 Else .ScrollTop = .ScrollTop + 3
                End Select
            End With
        End If
        Exit Function
    End If
    'partie gestion d'erreur
    DoEvents: Debug.Print Err.Number
    On Error GoTo 0
    
    'LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
End Function

 

[patricktoulon]

re

Spoiler: codeminimal

Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim DoNotCallNextHook As Boolean

    'Prevent Excel crash (e.g. Alt+F4 on UserForm with Hooked Control)
    On Error Resume Next ' Globale error gestion
    If ControlHooked Is Nothing Or Err.Number > 0 Then
        UnHookMouse
        Err.Clear: Exit Function
    Else
        If nCode = HC_ACTION Then
            If Not MouseIsOverTheBox Then Call UnHookMouse: Exit Function

            If wParam = WM_MOUSEWHEEL Then
                DoNotCallNextHook = True

                With ControlHooked
                      'Err.Clear  'absolutely useless

                    'Moves the ScrollBar depending on the mouse wheel, Info is stored in lParam
                    If GetHookStruct(lParam).mouseData > 0 Then
                        If .TopIndex < ScrollStep Then .TopIndex = 0 Else .TopIndex = .TopIndex - ScrollStep
                    Else
                        '!!!!!on fait pareil que a fait pour le "-" mais l'inverse
                        If .TopIndex < .ListCount - ScrollStep Then .TopIndex = .TopIndex + ScrollStep
                    End If

                End With
            End If
        End If
    End If

    If Not DoNotCallNextHook Then
        'triggers a new  hook if an error is incurred
        LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    Else
        LowLevelMouseProc = True 'callback of function
    End If

    On Error GoTo 0 'close and empty  the stack of error
End Function

 

[patricktoulon]

re
juste en passant @Dudu2 je viens de tester sur une feuille avec 4 panes ça marche plus
avec ton fichier 10

 

[Dudu2]

Je regarde lundi. Je suis en déplacement.

 

[Dudu2]

Voilà, de retour au PC.
Je fractionne, avec ou sans figer les volets, je Scroll le Pane 4 (où se trouvent les ActiveX) en vertical + horizontal.
Chez moi aucun problème sur les Controls ActiveX (je suppose que tu fais référence à ceux-ci).
Je suis étonné que tu aies ce problème car c'est le truc habituel Pan.PointsToScreenPixelsX/Y qui fonctionne sur toutes les versions d'Excel.

Le fichier à utiliser est celui de la ressource que j'ai créée:

VBA - Vertical Scroll en ComboBox, ListBox et TextBox (ActiveX en Feuille et en UserForm)

Le fichier à télécharger contient: Le Module_ScrollListComboTextBoxes à importer dans le projet VBA. Un UserForms de test contenant des ComboBoxes, des ListBoxes et des TextBoxes. Une feuille de test contenant une ComboBox, une ListBox et une...

excel-downloads.com

 

[Dudu2]

Il est vrai cependant qu'il y a un temps de latence de l'ordre d'une seconde sur le tout 1er Mouse Over de la ListBox1. Il faudrait que je trace mais je pense que l'évènement MouseMouve() se déclenche avec du retard. Ou c'est autre chose. Seules les traces donneront la raison.
Je joins un fichier de test.