Sujet Précédent Sujet Suivant

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

Paol8140 Messages postés 4 Date d'inscription mercredi 11 décembre 2019 Statut Membre Dernière intervention 12 décembre 2019 - 11 déc. 2019 à 16:45
Paol8140 Messages postés 4 Date d'inscription mercredi 11 décembre 2019 Statut Membre Dernière intervention 12 décembre 2019 - 12 déc. 2019 à 11:59
Je n'arrive pas à poser ma question directement dans la discussion mais ce code est génial sauf qu'il plante quand je scroll trop haut ou trop bas dans ma listbox.

Comment éviter cela?

MERCI BEAUCOUP D'AVANCE!!!!

6 réponses

Réponse 1 / 6
vb95 Messages postés 3472 Date d'inscription samedi 11 janvier 2014 Statut Contributeur Dernière intervention 13 avril 2024 169
12 déc. 2019 à 11:45
Bonjour !
Va voir les réponses et commentaires donnés pour ce code : https://codes-sources.commentcamarche.net/source/54334-vba-molette-souris-combobox-et-listebox-dans-feuille-excel-et-userform

Il parle d'une erreur dans le nom d'une procédure sur la Listbox
1
Réponse 2 / 6
vb95 Messages postés 3472 Date d'inscription samedi 11 janvier 2014 Statut Contributeur Dernière intervention 13 avril 2024 169
12 déc. 2019 à 11:47
bonjour !
Va voir dans les réponses de ce code :

Mimimazan a écrit :
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...
1
Réponse 3 / 6
vb95 Messages postés 3472 Date d'inscription samedi 11 janvier 2014 Statut Contributeur Dernière intervention 13 avril 2024 169
11 déc. 2019 à 23:52
Bonjour !
Sans code difficile de t'aider !
Pour poster du code voir https://codes-sources.commentcamarche.net/faq/11288-les-balises-de-code
0
Réponse 4 / 6
Paol8140 Messages postés 4 Date d'inscription mercredi 11 décembre 2019 Statut Membre Dernière intervention 12 décembre 2019
12 déc. 2019 à 09:10
Ok, je découvre ce forum.

Je voulais répondre à un ancien post sans y parvenir, si je ne suis pas assez clair, le titre de la discussion est:

molette souris combobox et listebox dans feuille excel et userform


Dans la Feuil: 

' 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 le Module: 
Option Explicit
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
   (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
   (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
   (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
 
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 LongPtr) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" _
   (ByVal hHook As LongPtr) 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 LongPtr
' sera associé à votre ComboBox/ListBox
Public CtrlHooked As Object
'
Private Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
    CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
    GetHookStruct = udtlParamStuct
End Function
Private Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    '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 LongPtr
    Dim hWnd_App As LongPtr
    Dim hWnd_Desk As LongPtr
    Dim hWnd_Sheet As LongPtr
    Dim hWnd_UserForm As LongPtr
    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 le 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


Je pense qu'il y a un souci au niveau de la gestion de la sortie de la liste avec la molette de la souris avec un unhook manquant???

Ou la partie du code: 
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



Qui gère ça, je crois?????

Merci du coup de main
0
vb95 Messages postés 3472 Date d'inscription samedi 11 janvier 2014 Statut Contributeur Dernière intervention 13 avril 2024 169
12 déc. 2019 à 11:49
Va voir dans les réponses de ce code : https://codes-sources.commentcamarche.net/source/54334-vba-molette-souris-combobox-et-listebox-dans-feuille-excel-et-userform

Mimimazan a signalé un problème
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 6
Paol8140 Messages postés 4 Date d'inscription mercredi 11 décembre 2019 Statut Membre Dernière intervention 12 décembre 2019
12 déc. 2019 à 11:57
Merci pour ces réponses.
Je continue mes recherches
0
Réponse 6 / 6
Paol8140 Messages postés 4 Date d'inscription mercredi 11 décembre 2019 Statut Membre Dernière intervention 12 décembre 2019
12 déc. 2019 à 11:59
Je crois comprendre que ce code foncitonne pour les combobox et listbox or il ne me semble utiliser qu'une listbox
0

Discussions similaires

Dessiner avec la souris
manou2005 -
babou6a -

6 réponses
EXCEL, faire l'inverse tangente atan pour avoir une valeur en degré minute
wind3813 -
wind3813 -

2 réponses
Calcul sur excel de l'inverse tangente en grade
HERTAN -
ucfoutu -

4 réponses
Les fonctions " racines niemmes " et " arctan "et "arccos " et "arcsin"
labriji -
labriji -

6 réponses
Dessiner un rond sur une image au clic de souris
madcap -
madcap -

23 réponses
Rejoignez-nous