Mouse Wheel Hook (faire défiler le contenu d'une combobox/listbox avec la roulette)

  • Initiateur de la discussion Compte Supprimé 979
  • Date de début

biboudeli

XLDnaute Nouveau
Bon ben, je n'y arrive pas :/

Si tu as un peu de temps Dudu2, ce serait génial si tu pouvais regarder ce qui ne va pas ^^
En gros, en colonne B, quand on selectionne "Enregistreur DI" ça lance mon userform et dedans on renseigne le batiment à la main alors que j'aimerais une liste (la liste est longue, située en feuille "Listes" , mais je n'arrive rien à faire défiler. Puis là ça beugue et je ne sais pas pourquoi :/

Si tu peux pas, tkt je comprendrai :)
 

Pièces jointes

  • Tableau des DI 6 - DEV EN COURS.xlsm
    363.7 KB · Affichages: 4

Dudu2

XLDnaute Barbatruc
Ok c'est Me.ComboBox1.ListIndex = 0 qui plante.
Ça ne marche pas parce que les Controls sont dans des Frames. C'est très joli mais c'est un cauchemar à gérer.
Je n'arrive même pas à les déplacer / supprimer, ça bousille complètement le UserForm.
Je vais essayer le code de chiendich pour voir s'il i s'en sort avec ça.
 

Dudu2

XLDnaute Barbatruc
Le code de chiendich ne fonctionne pas non plus.
J'ai sorti ComboBox1 du Frame mais ça ne marche pas non plus. Je ne comprends pas.
Faut que je cherche. Je ferai ça ce soir sauf si quelqu'un trouve la solution.
 

Dudu2

XLDnaute Barbatruc
Quel piège ! Le Scroll ne marche pas parce que.... il n'y a rien à scroller !!!
On est juste à la limite de la fenêtre de la ComboBox et on pourrait croire que la suite ne vient pas à cause d'un Scroll défaillant. Mais il n'y rien après !

Pourquoi as-tu mis: plageBatiment = .Range("G2:G" & .Range("X" & Rows.Count).End(xlUp).Row) ?
Mets plageBatiment = .Range("G2:G" & .Range("G" & Rows.Count).End(xlUp).Row) et cela fonctionnera.

Il serait bien que tu indentes ton code pour le rendre lisible.
 

Pièces jointes

  • Tableau des DI 6 - DEV EN COURS.xlsm
    348 KB · Affichages: 8

Dudu2

XLDnaute Barbatruc
Pour info ton classeur possède une liaison externe.
2020-11-13_135458.jpg


Si c'est voulu ça va, sinon il faut s'en débarrasser car ce n'est pas sain de trainer ces liaisons dans les classeurs.
 

biboudeli

XLDnaute Nouveau
Merci beaucoup @Dudu2 !!!
J'galérais tellement (ça m'arrive pourtant rarement les copier-coller foireux) sorry pour la prise de tête et merci infiniment de m'avoir aidé !

Et effectivement, j'vais enlever cette liaison, elle n'est pas du tout voulue ! ^^

Merciiii !!!
 

biboudeli

XLDnaute Nouveau
Haaaaa, j'suis désolée de te déranger encore @Dudu2 ! J'ai encore un p'tit problème non négligeable ^^ Le DoEvents reste bloqué et donc ça fait planter mon fichier.

En gros, une fois que je fais "remplir la ligne" le fichier ne veut plus que j'écrire dans mon tableau, j'ai juste accès à mes cases avec menu déroulant. Je ne comprend pas pourquoi. Mais quand je vais dans le menu de débogage, ça m'arrête sur DoEvents donc le problème ne doit pas être loin de ça je suppose.

Je te remet mon fichier (depuis j'ai ajouté un p'tit truc de saisie intuitive, mais c'est pas ça qui fait beuguer), j'ai essayé avec le fichier que tu m'as envoyé et ça beuguait de la même façon sur ce DoEvents, comme si la commande ne voulait pas arrêter de s'exécuter et qu'elle attendait quelque chose.
 

Pièces jointes

  • Tableau des DI 7 - En cours de modification VBA.xlsm
    111.6 KB · Affichages: 5

GClaire

XLDnaute Occasionnel
Hello la communauté.

Tout d'abord meilleurs vœux a toutes et tous. Et SURTOUT BONNE SANTE

Après une ré installation de win 10 64 bits et pack office 365, je rencontre un soucis sur cette procédure dés que je click sur une ComboBox.


VB:
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
    If plHooking < 1 Then    ' active le hook s'il n'avait pas déjà été activé
        Set CtrlHooked = ControlToScroll
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    End If
End Sub

Alors qu'avant tout fonctionné parfaitement.

Je me suis dit qu'il manquait peut être un complement ou autre dans excel, mais lequel?

Sinon, auriez vous une idée de ce qu'il ne va pas?

et aussi un truc de bizard :

sur ce code

Code:
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "USER32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "USER32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "USER32" (ByVal hHook As Long) As Long

Il 'a fallu mettre "PtrSafe" de partout sinon tout était en rouge, a priori la raison était que j'étais en 64Bits.

Par avance merci

Bonne soirée

G'Claire

1643222319559.png
 

GClaire

XLDnaute Occasionnel
Oups

VB:
'*******************************************
'multi hook simplifié (molete souris sur activx)
'défilement dans controls liste frame
'patricktoulon
'**********************************
Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "USER32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Private Declare PtrSafe Function CallNextHookEx Lib "USER32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "USER32" (ByVal hHook As LongPtr) As Long

#Else
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
    Private Declare PtrSafe Function SetWindowsHookEx Lib "USER32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
    Private Declare PtrSafe Function CallNextHookEx Lib "USER32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "USER32" (ByVal hHook As Long) As Long

#End If

Private Type POINTAPI: X As Long: Y As Long: End Type
Private Type MSLLHOOKSTRUCT: pt As POINTAPI: mouseData As Long: flags As Long: time As Long: dwExtraInfo As Long: End Type
Private Const HC_ACTION = 0
Private Const WH_MOUSE_LL = 14
Private Const WM_MOUSEWHEEL = &H20A
Private udtlParamStuct As MSLLHOOKSTRUCT
Public plHooking As Long    ' permet de savoir si le hook est activé ou pas
Public CtrlHooked As Object    ' sera associé à la ListBox

'
Private Function GetHookStruct(ByVal lParam As Long) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next    'en cas de mouvement très rapide,'évitons les crash en désactivant les erreurs
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                Select Case TypeName(CtrlHooked)    ' 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 - 2 Else .ScrollTop = .ScrollTop + 2
                End Select
            End With
        End If
        Exit Function
    End If
    LowLevelMouseProc = CallNextHookEx(0&, nCode, wParam, ByVal lParam)
    On Error GoTo 0
End Function
Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
    If plHooking < 1 Then    ' active le hook s'il n'avait pas déjà été activé
        Set CtrlHooked = ControlToScroll
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
    End If
End Sub
Public Sub UnHookMouse()
' désactive le hook s'il existe
    If plHooking <> 0 Then UnhookWindowsHookEx plHooking: plHooking = 0: Set CtrlHooked = Nothing
End Sub

et dans l'userform il y'a ces procédures :

Code:
Private Sub Cbx_N_OTP_DropButtonClick()
rouletambour Cbx_N_OTP
End Sub


Private Sub Cbx_N_OTP_Exit(ByVal Cancel As MSForms.ReturnBoolean)
UnHookMouse
End Sub

Private Sub rouletambour(obj)
        If Not CtrlHooked Is Nothing Then If CtrlHooked.Name <> obj.Name Then UnHookMouse
         Call HookMouse(obj)
End Sub


Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
UnHookMouse
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
UnHookMouse
Usf_Gestion_Horaire_Visible = False
End Sub
 

GClaire

XLDnaute Occasionnel
Patrick

Oui c'est bien ton modèle, lol.

Je vois comment je peux réduire le fichier, sinon je le met en entier, j'ai toujours peur de virer des trucs utils, lol.

es-ce que cela dérange?

Merci.
 

Statistiques des forums

Discussions
311 725
Messages
2 081 945
Membres
101 849
dernier inscrit
florentMIG