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

Excel Discussion :

scroll avec molette sur frame [Toutes versions]


Sujet :

Excel

  1. #1
    Membre régulier
    Homme Profil pro
    CIP
    Inscrit en
    Avril 2024
    Messages
    57
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : CIP
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2024
    Messages : 57
    Points : 93
    Points
    93
    Par défaut scroll avec molette sur frame
    Bonjour à tous
    quelqu'un aurait l'aimable attention de m'aider à corriger les déclarations d'api
    j'essaie en vain de le faire fonctionner sur toute les versions d'excel
    je sais plus si c'est longlong ,longptr ,parfois même selon diverses sources de long ça devrait passer à "any" etc
    bref je ne m'y retrouve plus
    si quelqu'un pourrait jeter un coup ça serait sympa
    merci scrollexemple 2.xlsm

  2. #2
    Membre régulier
    Homme Profil pro
    CIP
    Inscrit en
    Avril 2024
    Messages
    57
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : CIP
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2024
    Messages : 57
    Points : 93
    Points
    93
    Par défaut re:solution 32/64 bits
    re
    c'est bon j'ai fini par trouver ma solution
    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
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
     
    '*****************************************************************************************************
    '    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
    '   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
    '  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
    ' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
    '//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
    '****************************************************************************************************
    '*******************************************
    'hook mouse simplifié (molete souris sur frame)
    '
    'Author:patricktoulon
    '-------------------------------------
    'Exemple d'appel dans userform
    'L'object appelant peut être un control dans la frame à scroller
    '
    'Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' rouletambour Frame2
    'End Sub
    '------------------------------------
    'code indenté avec Vba Indenter 3.1
    '**********************************
     
    Option Explicit
     
    Type POINTAPI
        X As Long
        Y As Long
    End Type
     
    #If Win64 Then
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As LongPtr
    End Type
    #Else
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
    #End If
     
    #If Win64 Then
        Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
        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
        Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As Long, lParam As LongPtr) As LongPtr
        Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
        Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    #Else
        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
        Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    #End If
     
    Const HC_ACTION = 0
    Const WH_MOUSE_LL = 14
    Const WM_MOUSEWHEEL = &H20A
     
    Public udtlParamStuct As MSLLHOOKSTRUCT
     
    #If Win64 Then
        Public plHooking As LongPtr    ' permet de savoir si le hook est activé ou pas
    #Else
        Public plHooking As Long       ' permet de savoir si le hook est activé ou pas
    #End If
     
    Public CtrlHooked As Object    ' sera associé à la ListBox
    Public pos As POINTAPI
    Public EpC As Variant
     
    Sub rouletambour(obj)
        ' si ça n'a pas démarré, on démarre le hook
        If Not CtrlHooked Is Nothing Then
            If CtrlHooked.Name <> obj.Name Then UnHookMouse
        End If
        Call HookMouse(obj)
    End Sub
     
    Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
        CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
        GetHookStruct = udtlParamStuct
    End Function
     
    #If Win64 Then
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
    #Else
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    #End If
    On Error Resume Next        ' en cas de mouvement très rapide, évitons les crashs en désactivant les erreurs
    Dim Criter As Boolean, i&
    GetCursorPos pos
    Criter = plHooking <> 0
    Criter = Criter & IsArray(EpC)
    Criter = Criter & Not CtrlHooked Is Nothing
    Criter = Criter & wParam <> 0
    Criter = pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)        ' récupère les coordonnées en pixels (left/top/right/bottom du control)
    If Not Criter Then UnHookMouse: Exit Function
    If (nCode = HC_ACTION) Then
        If wParam = WM_MOUSEWHEEL Then
            LowLevelMouseProc = True
            With CtrlHooked
                If GetHookStruct(lParam).mouseData > 0 Then
                    .ScrollTop = .ScrollTop - 45
                Else
                    .ScrollTop = .ScrollTop + 45
                End If
            End With
        End If
        Exit Function
    End If
    If Err.numer Then Err.Clear: UnHookMouse
    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é
            EpC = EmplacementControl(ControlToScroll)    ' on récupère le rectangle du contrôle par rapport à l'écran (pas du parent) du contrôle dans un array
            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 If
    End Sub
     
    ' fonction du calendar reconvertie
    Function EmplacementControl(obj As Object)
        If Not obj Is Nothing Then
            Dim Lft As Double, Ltop As Double, ParentX As Object, ParentXInsWidth As Double, ParentXInsHeight As Double, K As Double, PPx, A, z
            Lft = obj.Left
            Ltop = obj.Top    ' Normalement Page, Frame ou UserForm
            Set ParentX = obj.Parent
            With CreateObject("WScript.Shell")
                PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72)
            End With
            Do
                ParentXInsWidth = ParentX.InsideWidth    ' Le Page en est pourvu, mais pas le Multipage
                ParentXInsHeight = ParentX.InsideHeight
                If TypeOf ParentX Is MSForms.Page Then Set ParentX = ParentX.Parent    ' Prend le Multipage, car le Page est sans positionnement
                K = (ParentX.Width - ParentXInsWidth) / 2
                Lft = (Lft + ParentX.Left + K)
                Ltop = (Ltop + ParentX.Top + ParentX.Height - K - ParentXInsHeight)
                If Not (TypeOf ParentX Is MSForms.Frame Or TypeOf ParentX Is MSForms.MultiPage) Then Exit Do
                Set ParentX = ParentX.Parent
            Loop
            EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height) / PPx)
        End If
    End Function

  3. #3
    Membre actif
    Homme Profil pro
    libre
    Inscrit en
    Mai 2024
    Messages
    114
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : Autre

    Informations professionnelles :
    Activité : libre

    Informations forums :
    Inscription : Mai 2024
    Messages : 114
    Points : 209
    Points
    209
    Par défaut
    Je ne pense pas que cette déclaration est compatible avec toutes les versions de l'Office LongPtr et PtrSafe n'existaient pas avant l'Office 2010 il faut tenir en compte également de la version du VBA


    https://arkham46.developpez.com/arti...a64bits/#LIV-C

  4. #4
    Membre régulier
    Homme Profil pro
    CIP
    Inscrit en
    Avril 2024
    Messages
    57
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : CIP
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2024
    Messages : 57
    Points : 93
    Points
    93
    Par défaut re
    Bonjour Volid

    si si ça fonctionnera
    tout simplement par ce que les versions 32 bits de excel (2007 et vb6 / 2010 et vba7 / 2013 et vba7 / 2016 etc ) fonctionnent très bien avec les déclarations vb6
    j'ai testé
    peut être y aura il des nuances avec les version clickandrun qui n'auront pas vb6 installée (je sais pas j'en suis pas sur j'ai personne sous la main pour tester)
    mais toutes les versions iso ou disk l'ont avec le vba 7

    donc pas de soucis d'ailleurs je te le prouve sur 2013 32 bits qui fonctionne aussi bien avec les déclarations vba7 que vba6
    Nom : demo2.gif
Affichages : 98
Taille : 450,0 Ko

    avec certaines api je te l'accorde il y aura quand même a être en vba7
    mais la c'est pas le cas

  5. #5
    Membre chevronné
    Profil pro
    Inscrit en
    Juillet 2006
    Messages
    1 301
    Détails du profil
    Informations personnelles :
    Localisation : France, Paris (Île de France)

    Informations forums :
    Inscription : Juillet 2006
    Messages : 1 301
    Points : 1 900
    Points
    1 900
    Par défaut
    @patmeziere:
    Ne t'enflamme pas trop vite.
    Quid du 64 bits ?

  6. #6
    Membre régulier
    Homme Profil pro
    CIP
    Inscrit en
    Avril 2024
    Messages
    57
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : CIP
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2024
    Messages : 57
    Points : 93
    Points
    93
    Par défaut re
    Bonjour deedolith

    si il y en a bien un qui s'enflamme pas pour le 64 bits c'est bien moi

  7. #7
    Responsable
    Office & Excel


    Homme Profil pro
    Formateur et développeur chez EXCELLEZ.net
    Inscrit en
    Novembre 2003
    Messages
    19 124
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 57
    Localisation : Belgique

    Informations professionnelles :
    Activité : Formateur et développeur chez EXCELLEZ.net
    Secteur : Enseignement

    Informations forums :
    Inscription : Novembre 2003
    Messages : 19 124
    Points : 55 905
    Points
    55 905
    Billets dans le blog
    131
    Par défaut
    Salut.

    Je me demande s'il ne faut pas aussi tester #If VBA7 Then... car c'est le VBA7 qui utilise ptrSafe
    "Plus les hommes seront éclairés, plus ils seront libres" (Voltaire)
    ---------------
    Mes billets de blog sur DVP
    Mes remarques et critiques sont purement techniques. Ne les prenez jamais pour des attaques personnelles...
    Pensez à utiliser les tableaux structurés. Ils vous simplifieront la vie, tant en Excel qu'en VBA ==> mon tuto
    Le VBA ne palliera jamais une mauvaise conception de classeur ou un manque de connaissances des outils natifs d'Excel...
    Ce ne sont pas des bonnes pratiques parce que ce sont les miennes, ce sont les miennes parce que ce sont des bonnes pratiques
    VBA pour Excel? Pensez D'ABORD en EXCEL avant de penser en VBA...
    ---------------

  8. #8
    Membre régulier
    Homme Profil pro
    CIP
    Inscrit en
    Avril 2024
    Messages
    57
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 54
    Localisation : France, Ille et Vilaine (Bretagne)

    Informations professionnelles :
    Activité : CIP
    Secteur : Service public

    Informations forums :
    Inscription : Avril 2024
    Messages : 57
    Points : 93
    Points
    93
    Par défaut re
    re
    bonjour Pierre Fauconnier
    oui sur le fond c'est vrai sauf que long ne fonctionnepas et crasch carrément excel sur les versions 64 bits
    et comme je suis sur 2013 32 bits et que cette version n'a que faire du vba6 ou 7 et que donc les declarations vb6 fonctionnent tout aussi bien
    je le fait que sur win64
    c'est pas nouveau ce problème de scroll avec la mollette mais comme j'en ai vraiment besoins dans mon applicatif (très grands textbox multiligne)
    je me bas pour le faire fonctionner sur 64 aussi bien que chez moi sur 2013 ou 2016 en 32 bits
    au fur et à mesure que j'avance je me rends compte que ca vient de plusieurs chose

    1° la première étant une certaine latence plus importante sur les versions 64

    2°la seconde et je viens de le découvrir c'est les appels éventuellement répétés sur le même control
    il semblerait que comme le thread change (plhooking) ça s'empile quelque part en mémoire (je n'ai pas d'explication sur ce point )

    3° les versions 2019 et 2021 qui l'ont testé en 64 bits (deux mêmes versions sur deux pc différents)semblent réagir différemment (ce qui facilite pas la tâche)

    j'ai donc ajouté le test sur le control lui même au lieu du thread(plhooking) et la j'ai ma console de débogage qui se repose enfin
    l'affichage du curseur de la souris est moins saccadé (même sur 2013 c'est visible à l’œil nu)

    je pense donc qu'en plus de la gestion critique dans la fonction exécuté dans l'addressof ,il faut gérer la nécessité des appels afin d'éviter de surcharger la mémoire
    si j'avais mis les debug avant je m'en serait rendu compte plus tôt
    je pense que celle ci devrait fonctionner avec beaucoup plus de souplesse
    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
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    '*****************************************************************************************************
     
    '*****************************************************************************************************
    '    ___     _     _______  __      _   ____  _   _  _______  ___     _   _   _    ___     _     _.
    '   //  \\  /\\      //    // \\   //  //    //  //    //    //  \\  //  //  //   //  \\  //|   //
    '  //___// //__\    //    //__//  //  //    //__//    //    //   // //  //  //   //   // // |  //
    ' //      //   \\  //    //  \\  //  //    //  \\    //    //   // //  //  //   //   // //  | //
    '//      //    // //    //   // //  //___ //    \\  //     \\__// //__//  //___ \\__// //   |//
    '****************************************************************************************************
    '*******************************************
    'hook mouse simplifié (mollete souris)
    '
    'Author:patricktoulon
    '-------------------------------------
    'Exemple d'appel dans userform
    'L'object appelant peut être un control dans le control à scroller
    '
    'Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    ' rouletambour Frame2
    'End Sub
    '------------------------------------
    'code indenté avec Vba Indenter 3.1
    '**********************************
     
    Option Explicit
     
    Type POINTAPI
        X As Long
        Y As Long
    End Type
     
    #If Win64 Then
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As LongPtr
    End Type
    #Else
    Private Type MSLLHOOKSTRUCT
        pt As POINTAPI
        mouseData As Long
        flags As Long
        time As Long
        dwExtraInfo As Long
    End Type
    #End If
     
    #If Win64 Then
        Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
        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
        Declare PtrSafe Function CallNextHookEx Lib "user32" (ByVal hHook As LongPtr, ByVal nCode As Long, ByVal wParam As Long, lParam As LongPtr) As LongPtr
        Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As LongPtr) As Long
        Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    #Else
        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
        Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    #End If
     
    Const HC_ACTION = 0
    Const WH_MOUSE_LL = 14
    Const WM_MOUSEWHEEL = &H20A
     
    Public udtlParamStuct As MSLLHOOKSTRUCT
     
    #If Win64 Then
        Public plHooking As LongPtr    ' To know if the hook is active or not
    #Else
        Public plHooking As Long       ' To know if the hook is active or not
    #End If
     
    Public CtrlHooked As Object    ' Will be associated with the ListBox
    Public pos As POINTAPI
    Public EpC As Variant
    Public PosY As Long
     
    Sub rouletambour(obj)
        ' Start the hook if it hasn't started yet
        If Not CtrlHooked Is Nothing Then
            If CtrlHooked.Name <> obj.Name Then UnHookMouse
        End If
        Call HookMouse(obj)
    End Sub
     
    Function GetHookStruct(ByVal lParam As LongPtr) As MSLLHOOKSTRUCT
        CopyMemory VarPtr(udtlParamStuct), lParam, LenB(udtlParamStuct)
        GetHookStruct = udtlParamStuct
    End Function
     
    #If Win64 Then
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As LongPtr) As LongPtr
    #Else
    Function LowLevelMouseProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    #End If
    On Error GoTo ErrorCritique    ' Improved error handling
     
    Dim Criter As Boolean, i&, Mdata
    GetCursorPos pos
    Criter = plHooking <> 0 'si le thread plhooking <>0 c'est bon
    Criter = Criter And IsArray(EpC) 'si EpC est un array c'est bon
    Criter = Criter And Not CtrlHooked Is Nothing 'si CtrlHooked n'est pas nothing c'est bon
    Criter = Criter And wParam <> 0 'si wparam <>0alors la struture  de la mouse  a été captée
    'et en fin si les coordonnées sont dans le rectangle corespondant au corordonnées du rectangle du control  c'est bon
    Criter = Criter And pos.X > EpC(0) And pos.X < EpC(2) And pos.Y > EpC(1) And pos.Y < EpC(3)    ' Get control's coordinates in pixels
     
    If Not Criter Then UnHookMouse: Exit Function 'possibilité non critique criter est false alors on sort(le move sur control refera un nouvel appel)
    If (nCode = HC_ACTION) Then 'si ncode renvoie bien action alors on est bon la structure est captée
        If wParam = WM_MOUSEWHEEL Then 'si wparam renvoie bien 522 soit &H20A  alors la structure est bonne
            LowLevelMouseProc = True 'alors on est true(32 bits relance le hook en looping (pas le 64)
            Mdata = GetHookStruct(lParam).mouseData 'on récupère le mouse data
            With CtrlHooked
                CtrlHooked.SetFocus
               'selon le control appellant (ou designé)
                'on testera le typeof et le typename selon les configs typeof renvoie une mauvaise reponse
                Select Case True
                    Case TypeOf CtrlHooked Is Frame Or TypeName(CtrlHooked) = "Frame"
                        If Mdata > 0 Then .ScrollTop = .ScrollTop - 45 Else .ScrollTop = .ScrollTop + 45
     
                    Case TypeOf CtrlHooked Is ListBox Or TypeName(CtrlHooked) = "ListBox"
                        If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
     
                    Case TypeOf CtrlHooked Is ComboBox Or TypeName(CtrlHooked) = "ComboBox"
                        If Mdata > 0 Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1
     
                    Case TypeOf CtrlHooked Is TextBox Or TypeName(CtrlHooked) = "TextBox"
                        If Mdata > 0 Then
                            CtrlHooked.CurLine = Application.Max(0, CtrlHooked.CurLine - 2)
                        Else
                            CtrlHooked.CurLine = Application.Min(CtrlHooked.LineCount - 1, CtrlHooked.CurLine + 2)
                        End If
     
                    Case TypeOf CtrlHooked Is ScrollBar Or TypeName(CtrlHooked) = "ScrollBar"
                        If Mdata > 0 Then .Value = .Value - 1 Else .Value = .Value + 1
                End Select
            End With
        End If
        Exit Function 'ici on sort tout c'est bien passé
    End If
    '----------------------------------'
    'Gestion d'erreur critique dans un switch entre deux exit function
    Nettoyage: 'ici on a été renvoyé par errorCritique
        If Err.Number <> 0 Then Err.Clear: UnHookMouse
        On Error GoTo 0
        LowLevelMouseProc = CallNextHookEx(plHooking, nCode, wParam, lParam) 'évidemment là on est obligé de rappeller car tout est mort ,dead ,ralbate ,crevé etc...
     
        Debug.Print "on sort en catastrophe de " & CtrlHooked.Name: Exit Function ' on sort on va pas boucler sur une erreur ca suffit une fois espece de saucisse!!!!
     
    ErrorCritique:
       Debug.Print "erreur critique" & CtrlHooked.Name
       MsgBox "Une erreur est survenue pendant hook " & vbCrLf & Err.Description, vbCritical
        Resume Nettoyage ' on renvoie au nettoyage pour tout nettoyer et relancer avec callnexthook neccessaire cette fois ci car externe à la partie ou tout se passe bien
    End Function
     
    Public Sub HookMouse(ByVal ControlToScroll As Object, Optional ByVal FormName As String)
      If Not CtrlHooked Is Nothing Then If CtrlHooked.Name = ControlToScroll.Name Then Exit Sub
       If plHooking <> 0 Then Debug.Print "on sort de " & CtrlHooked.Name & " et on entre dans " & ControlToScroll.Name: UnHookMouse: Exit Sub
          If plHooking < 1 Then    ' active le hook si un autre n'est pas démarré
            EpC = EmplacementControl(ControlToScroll)    ' Get the control's rectangle relative to the screen (not the parent) into an array
            Set CtrlHooked = ControlToScroll
            plHooking = SetWindowsHookEx(WH_MOUSE_LL, AddressOf LowLevelMouseProc, 0, 0)
        End If
    End Sub
     
    Public Sub UnHookMouse()
        ' Déactive le hook si un thread(plHooking) a été précédemment démarré
        If plHooking <> 0 Then
            UnhookWindowsHookEx (plHooking)
            plHooking = 0
            Set CtrlHooked = Nothing
        End If
        PosY = 0
    End Sub
     
    ' fonction du calendar reconvertie
    Function EmplacementControl(obj As Object)
        If Not obj Is Nothing Then
            Dim Lft As Double, Ltop As Double, plus, ParentX As Object, ParentXInsWidth As Double, ParentXInsHeight As Double, K As Double, PPx, A, z
            With CreateObject("WScript.Shell")
                PPx = 1 / (.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\ThemeManager\LastLoadedDPI") / 72)
            End With
            If Not TypeOf obj.Parent Is Worksheet And Not TypeName(obj) = "WorkSheet" Then
                If PosY > obj.Height Then plus = (obj.Font.Size / 0.75 - 1) * obj.ListRows Else plus = 0
                Lft = obj.Left
                Ltop = obj.Top    ' Normalement Page, Frame ou UserForm
                Set ParentX = obj.Parent
                Do
                    ParentXInsWidth = ParentX.InsideWidth    ' Le Page en est pourvu, mais pas le Multipage
                    ParentXInsHeight = ParentX.InsideHeight
                    If TypeOf ParentX Is MSForms.Page Then Set ParentX = ParentX.Parent    ' Prend le Multipage, car le Page est sans positionnement
                    K = (ParentX.Width - ParentXInsWidth) / 2
                    Lft = (Lft + ParentX.Left + K)
                    Ltop = (Ltop + ParentX.Top + ParentX.Height - K - ParentXInsHeight)
                    If Not (TypeOf ParentX Is MSForms.Frame Or TypeOf ParentX Is MSForms.MultiPage) Then Exit Do
                    Set ParentX = ParentX.Parent
                Loop
                EmplacementControl = Array(Lft / PPx, Ltop / PPx, (Lft + obj.Width) / PPx, (Ltop + obj.Height + plus) / PPx)
            End If
        Else
            'plus tard !!! pour les oleobject  oleobject in worksheet(voir tuto patricktoulon pointoscreenpixel)
            'Debug.Print Join(EmplacementControl, "-----")
        End If
    End Function
    je n'ai plus de saccades pendant le scroll c'est beaucoup plus fluide
    Nom : demo2.gif
Affichages : 70
Taille : 258,4 Ko
    Fichiers attachés Fichiers attachés

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. Incrémenter une variable lors du scroll avec la molette
    Par Invité dans le forum Général JavaScript
    Réponses: 2
    Dernier message: 27/01/2022, 09h25
  2. Gestion des scroll avec molette et key
    Par ppphil dans le forum C#
    Réponses: 4
    Dernier message: 08/01/2010, 16h30
  3. [Prototype] Scroll avec la molette de la souris dans un div
    Par epeichette dans le forum Bibliothèques & Frameworks
    Réponses: 3
    Dernier message: 02/07/2009, 14h43
  4. Faire défiler une frame avec le scroll d'une autre frame
    Par identifiant_bidon dans le forum Général JavaScript
    Réponses: 1
    Dernier message: 11/08/2007, 14h39
  5. [javascript] Scroll avec une image
    Par Salih-du-91 dans le forum Général JavaScript
    Réponses: 4
    Dernier message: 05/10/2005, 07h46

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