IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Hook Scroll MouseWhelle plante


Sujet :

Macros et VBA Excel

Vue hybride

Message précédent Message précédent   Message suivant Message suivant
  1. #1
    Membre éprouvé
    Homme Profil pro
    Inscrit en
    Mai 2012
    Messages
    1 150
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Mai 2012
    Messages : 1 150
    Par défaut Hook Scroll MouseWhelle plante
    Bonjour,
    Je souhaiterais utiliser la roulette de ma souris dans une listbox d'un userform, en fouillant sur internet j'ai trouvé un code qui fait ce que je veux, à la seule exception qu'il plante lorsque je scroll trop haut ou trop bas.

    Comment éliminer ce plantage?

    Le code:

    Feuille:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
     
    ' 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:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
     
    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:
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
     
     
    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
    Merci beaucoup pour toute aide, ce code est génial mais le hic est d'importance!!!!!

  2. #2
    Membre éprouvé
    Homme Profil pro
    Inscrit en
    Mai 2012
    Messages
    1 150
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Mai 2012
    Messages : 1 150
    Par défaut
    Je précise mes propos, le fichier se ferme sans coup férir quand je scroll trop bas ou trop haut dans la liste.
    Manquerait-il un unhook pour gérer ce cas?

  3. #3
    Membre éprouvé
    Homme Profil pro
    Inscrit en
    Mai 2012
    Messages
    1 150
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France

    Informations forums :
    Inscription : Mai 2012
    Messages : 1 150
    Par défaut
    Y a-t-il un problème ici:

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
     
    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
    ?????

Discussions similaires

  1. L'explorateur windows 8.1 plante au scrolling
    Par kiltea dans le forum Windows 8
    Réponses: 0
    Dernier message: 16/12/2013, 11h28
  2. touche pour accéder à une application : hook system?
    Par Fox_magic dans le forum API, COM et SDKs
    Réponses: 3
    Dernier message: 22/01/2003, 00h02
  3. Réponses: 2
    Dernier message: 23/10/2002, 13h38
  4. scroll dans un label
    Par Pretender dans le forum Composants VCL
    Réponses: 9
    Dernier message: 27/09/2002, 17h06

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo