scroll avec molette sur frame

Version imprimable

20/05/2024, 09h43
patmeziere

1 pièce(s) jointe(s)

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 Pièce jointe 654897

re:solution 32/64 bits

re
c'est bon j'ai fini par trouver ma solution

Code:

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

23/05/2024, 19h06
Invité

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
23/05/2024, 19h18
patmeziere

1 pièce(s) jointe(s)

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
Pièce jointe 655098

avec certaines api je te l'accorde il y aura quand même a être en vba7
mais la c'est pas le cas
23/05/2024, 21h27
deedolith

@patmeziere:
Ne t'enflamme pas trop vite.
Quid du 64 bits ?
24/05/2024, 07h23
patmeziere

re

Bonjour deedolith

si il y en a bien un qui s'enflamme pas pour le 64 bits c'est bien moi :ptdr:
24/05/2024, 19h19
Pierre Fauconnier

Salut.

Je me demande s'il ne faut pas aussi tester #If VBA7 Then... car c'est le VBA7 qui utilise ptrSafe

2 pièce(s) jointe(s)

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 :roll:
je pense que celle ci devrait fonctionner avec beaucoup plus de souplesse

Code:

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
Pièce jointe 655146