[vba] molette souris combobox et listebox dans feuille excel et userform

Soyez le premier à donner votre avis sur cette source.

Vue 26 857 fois - Téléchargée 2 519 fois

Télécharger le projet
Commenter

Description

Prise en charge de la molette de la souris pour ComboBox et ListBox d'une feuille excel ou d'une UserForm. Un fichier à ajouter dans vos documents excel pour utiliser la molette. On peut trouver facilement un code source pour utiliser la molette de la souris avec ComboBox ou ListeBox dans une UserForm. Mais j'ai eu des difficultés pour trouver un code source afin d'utiliser la molette avec ces objets insérés dans une feuille excel. Donc, rien d'extraordinaire, la méthode est basée sur un hook classic. Sauf que le handle hooké a justement été l'élément que j'ai galéré à identifier afin que ces deux objets puissent utiliser la molette. Le code du module n'est pas de moi. Je l'ai un peu modifié pour le rendre facilement réutilisable.

Source / Exemple : 


'-------------------------
' Dans une feuille excel :
'
Private Sub ComboBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call HookMouse(ComboBox1, eSHEET)
End Sub
Private Sub ComboBox1_Click()
    ' pour valider le choix de la valeur par l'utilisateur, on va ailleurs
    Feuil1.Range("A1").Activate
End Sub
Private Sub ComboBox1_LostFocus()
    ' désactive le hook en sortant de la liste
    UnHookMouse
End Sub
Private Sub Worksheet_Deactivate()
    ' désactive le hook si on change de feuille, évitons les risques de crash
    UnHookMouse
End Sub
' Ci-dessous, exemple sur une ListBox
Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call HookMouse(ListBox1, eSHEET)
End Sub
Private Sub ListBox1_LostFocus()
    UnHookMouse
End Sub

'-----------------
' Dans un module :
'
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
Private Declare 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 Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Enum OWNER
    eSHEET = 1
    eUSERFORM = 2
End Enum
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 Const GWL_HINSTANCE = (-6)
Private udtlParamStuct As MSLLHOOKSTRUCT
' permet de savoir si le hook est activé ou pas
Public plHooking As Long
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
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
    'en cas de mouvement très rapide,
    'évitons les crash en désactivant les erreurs
    On Error Resume Next
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
            ' déplace l'ascenseur en fonction de la molette
                ' l'info est stockée dans lParam
                If GetHookStruct(lParam).mouseData > 0 Then
                    .TopIndex = .TopIndex - 3
                Else
                    .TopIndex = .TopIndex + 3
                End If
            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, ByVal SheetOrForm As OWNER, Optional ByVal FormName As String)
    Dim hWnd As Long
    Dim hWnd_App As Long
    Dim hWnd_Desk As Long
    Dim hWnd_Sheet As Long
    Dim hWnd_UserForm As Long
    Const VBA_EXCEL_CLASSNAME = "XLMAIN"
    Const VBA_EXCELSHEET_CLASSNAME = "EXCEL7"
    Const VBA_EXCELWORKBOOK_CLASSNAME = "XLDESK"
    Const VBA_USERFORM_CLASSNAME = "ThunderDFrame"
    ' active le hook s'il n'avait pas déjà été activé
    If plHooking < 1 Then
        ' retourne l'handle d'excel
        hWnd_App = FindWindow(VBA_EXCEL_CLASSNAME, vbNullString)
        Select Case SheetOrForm
        Case eSHEET
            'trouve son fils
            hWnd_Desk = FindWindowEx(hWnd_App, 0&, VBA_EXCELWORKBOOK_CLASSNAME, vbNullString)
            'trouve celui de la feuille
            hWnd_Sheet = FindWindowEx(hWnd_Desk, 0&, VBA_EXCELSHEET_CLASSNAME, vbNullString)
            hWnd = hWnd_Sheet
        Case eUSERFORM
            'trouve la UserForm
            hWnd_UserForm = FindWindowEx(hWnd_App, 0&, VBA_USERFORM_CLASSNAME, FormName)
            If hWnd_UserForm = 0 Then
                hWnd_UserForm = FindWindow(VBA_USERFORM_CLASSNAME, FormName)
            End If
            hWnd = hWnd_UserForm
        End Select
        Set CtrlHooked = ControlToScroll
        ' il n'y a pas de hInstance d'application, alors on utilise GetWindowLong pour obtenir l'hInstance
        plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, GetWindowLong(hWnd, GWL_HINSTANCE), 0)
        Debug.Print Timer, "Hook ON"
    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
        Debug.Print Timer, "Hook OFF"
    End If
End Sub

'--------------------
' Dans une UserForm :
'
Private Sub ComboBox1_Enter()
    Call HookMouse(Me.ComboBox1, eUSERFORM, Me.Name)
End Sub
Private Sub ComboBox1_Click()
    Me.cmdQuit.SetFocus
    UnHookMouse
End Sub
Private Sub ListBox1_Enter()
    Call HookMouse(Me.ListBox1, eUSERFORM, Me.Name)
End Sub
Private Sub ListBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    UnHookMouse
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    UnHookMouse
End Sub

Conclusion :


Module facilement intégrable dans vos documents excel.
Télécharger le projet

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Philippe734 Messages postés 308 Date d'inscription lundi 16 décembre 2002 Statut Membre Dernière intervention 15 juin 2015 1
27 mai 2012 à 15:17
à renfield : si tu passe par là, sache que j'ai beaucoup travaillé avec tes modules de ta source :
vbfrance.com/codes/MODULE-SUBCLASSER_38442.aspx
En ce qui concerne un ComboBox inséré dans une feuille excel (pas sur une UserForm),
J'ai donc cherché avec obsession à ajouter la prise en charge de la molette avec tes modules de subclassing. Après de nombreux essais et différent handles tentés, je n'ai pas réussis à identifier le bon handle de la liste déroulante d'un ComboBox inséré dans une feuille. Si j'utilise le handle de cette présente source, alors excel plante lors l'event LostFocus du combo. Tout ça pour dire que j'ai bien galéré pour finalement faire un hook classic !
mimiZanzan Messages postés 301 Date d'inscription lundi 27 février 2006 Statut Membre Dernière intervention 17 décembre 2017
4 juin 2012 à 15:37
Parfait, fonctionne très bien.
C'est dingue ce qu'on peut faire avec les hooks!
Peut en effet être très utile.

Cdt
IgorHagard
25 févr. 2013 à 21:53
Toujours utile un an plus tard.
J'ai pas le niveau pour l'écrire, à peine le niveau pour comprendre...
Et pourtant tu me permets de l'utiliser sans difficulté : merci à toi !
Enalim
14 mars 2013 à 17:32
Bonjour, code très utile :)

Je l'ai testé mais je n'arrive pas à le faire fonctionner pour un nom de Userform différent de "UserForm1"

Sachant que j'ai plusieurs Userform où j'aurais besoin de la molette pour ComboBox, est-ce que quelqu'un aurait la bontée de m'aider s'il vous plait?
mimiZanzan Messages postés 301 Date d'inscription lundi 27 février 2006 Statut Membre Dernière intervention 17 décembre 2017
16 mars 2013 à 15:57
Bonjour Philippe 734,

Je sais que je tarde un peu à réagir, mais je tiens quand même à te signaler une légère erreur dans ton code qui empêche le bon fonctionnement de la molette dans le cas de la listbox de l'userform: les lignes
' Me.cmdQuit.SetFocus
' UnHookMouse
doivent être dans la Private Sub ComboBox1_Exit au lieu de la Private Sub ComboBox1_Click().
Ceci n'empêche pas ton code d'être super, c'est certainement une faute d'inattention...

Cordialement
S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (Philippe734)