Erreur ProgressBar

**kelly27** · 06/11/2014, 00h08

Bonjour à toutes et tous.
J'ai lu cette contribution.
Je suis sous W7, 64bits, et j’utilise Excel 2010.
J’obtiens l’erreur 53 : fichier introuvable : olepro32.dll
Ci-dessous la macro adaptée en vba7 mais l’erreur persiste.
Je sollicite votre aide.

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
'"""""""""""""""""""""""""""MODULE POUR INSERER UNE PROGRESSBARRE PERSO""""""""""""""""""""""""""""""
'                                                                                                   "
'                                creation patricktoulon                                             "
'                                                                                                   "
'                               Theme : personalisation des applications                            "
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
 
Option Explicit
 
'je les met en constante afin de ne pas avoir a metre les Guillemets quand on l'injecte en argument dans l'apel a la fonction
Public Const blueseven = "blueseven"
Public Const wood = "wood"
Public Const blood = "blood"
Public Const darkblue = "darkblue"
Public Const lady = "lady"
Public Const XPcorporate = "XPcorporate"
Public Const vista = "vista"
Public Const XP = "XP"
Public Const vertical = "vertical"
Public Const silver = "silver"
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(8) As Byte
End Type
 
Public Type PICTDESC
    cbSize As Long
    picType As Long
    hImage As Long
End Type
#If VBA7 Then
Public Declare PtrSafe Function OpenClipboard& Lib "User32" (ByVal hwnd As Long)
Public Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Public Declare PtrSafe Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Public Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare PtrSafe Function CloseClipboard& Lib "User32" ()
Public Declare PtrSafe Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#Else
Public Declare Function OpenClipboard& Lib "User32" (ByVal hwnd As Long)
Public Declare Function EmptyClipboard Lib "User32" () As Long
Public Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Public Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare Function CloseClipboard& Lib "User32" ()
Public Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#End If
Public slider As Object
Public largeur As Long
Public hauteur As Long
Public maform As Object
Public iPic As IPicture
Public sens As Variant
'Public fin As Long
Public i As Long
Public e As Long
Dim couleur_slider As Variant
Dim couleur_cadre As Variant
 
 
Function Progressbarre(e, fin)
    On Error Resume Next
    If sens = vertical Then
        slider.Height = (hauteur / fin) * e
        slider.Top = maform.fondprogress.Top + (hauteur - (hauteur / fin) * e) + 1    '(fondprogress.Top + fondprogress.Height - 2) + difference
    ElseIf sens <> vertical Then slider.Width = (largeur / fin) * e
    End If
    DoEvents    ' ne pas oublié de mettre ce doevents sinon l'effet est trop rapide
    On Error GoTo 0
End Function

**patricktoulon** · 06/11/2014, 05h21

Bonjour

il manque une bonne partie du code c'est normal

**kelly27** · 06/11/2014, 05h42

Bonjour

En fait je n'ai joint sur le message que la partie du code que j’ai modifié pour la compatibilité avec le 64bits.
Je me suis inspirée d’un conseil que vous aviez donné sur un autre topic.

Cordialement

**patricktoulon** · 06/11/2014, 09h45

re
sur quel n° de ligne tu a une erreur ?

**kelly27** · 06/11/2014, 10h04

Je viens de faire un vba inspector

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
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
'                                                                                                   "
'                                creation patricktoulon                                             "
'                                                                                                   "
'                               Theme : personalisation des applications                            "
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
 
Option Explicit
 
'je les met en constante afin de ne pas avoir a metre les Guillemets quand on l'injecte en argument dans l'apel a la fonction
Public Const blueseven = "blueseven"
Public Const wood = "wood"
Public Const blood = "blood"
Public Const darkblue = "darkblue"
Public Const lady = "lady"
Public Const XPcorporate = "XPcorporate"
Public Const vista = "vista"
Public Const XP = "XP"
Public Const vertical = "vertical"
Public Const silver = "silver"
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(8) As Byte
End Type
 
Public Type PICTDESC
    cbSize As Long
    picType As Long
    hImage As Long
End Type
#If VBA7 Then
Public Declare PtrSafe Function OpenClipboard& Lib "User32" (ByVal hwnd As Long)
Public Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
Public Declare PtrSafe Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Public Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Declare PtrSafe Function CloseClipboard& Lib "User32" ()
Public Declare PtrSafe Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#Else
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>NO EXACT MATCH: References a known Win32 Library [user32]</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function OpenClipboard& Lib "User32" (ByVal hwnd As Long)
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>UPDATED: Declare PtrSafe Function EmptyClipboard Lib "user32" Alias "EmptyClipboard" () As Long</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function EmptyClipboard Lib "User32" () As Long
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>NO EXACT MATCH: References a known Win32 Library [user32]</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>UPDATED: Declare PtrSafe Function SetClipboardData Lib "user32" Alias "SetClipboardDataA" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>NO EXACT MATCH: References a known Win32 Library [user32]</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function CloseClipboard& Lib "User32" ()
'<VBA_INSPECTOR>
'   <DECLARE>
'       <MESSAGE>Contains a Windows 32-bit API call that will need to be updated for 64bit compatibility.</MESSAGE>
'       <ITEM>NO EXACT MATCH: References a known Win32 Library [user32]</ITEM>
'       <URL><a href="http://go.microsoft.com/fwlink/?LinkId=177572" target="_blank">http://go.microsoft.com/fwlink/?LinkId=177572</a>  </URL>
'   </DECLARE>
'</VBA_INSPECTOR>
Public Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Public Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#End If
Public slider As Object
Public largeur As Long
Public hauteur As Long
Public maform As Object
Public iPic As IPicture
Public sens As Variant
'Public fin As Long
Public i As Long
Public e As Long
Dim couleur_slider As Variant
Dim couleur_cadre As Variant
 
 
Function Progressbarre(e, fin)
    On Error Resume Next
    If sens = vertical Then
        slider.Height = (hauteur / fin) * e
        '<VBA_INSPECTOR>
        '   <DEPRECATION>
        '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
        '       <ITEM>[mso]Assistant.Top</ITEM>
        '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215358" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215358</a> /URL>
        '   </DEPRECATION>
        '</VBA_INSPECTOR>
        slider.Top = maform.fondprogress.Top + (hauteur - (hauteur / fin) * e) + 1    '(fondprogress.Top + fondprogress.Height - 2) + difference
    ElseIf sens <> vertical Then slider.Width = (largeur / fin) * e
    End If
    DoEvents    ' ne pas oublié de mettre ce doevents sinon l'effet est trop rapide
    On Error GoTo 0
End Function
 
 
'on prend un cliché on en fait un bitmap
Public Function progress_bar_perso(usf, Optional le_style As String = "vista")
    Set maform = usf
maform.fondprogress.Caption = ""
    maform.fondprogress.BackStyle = 0    'on rend transparent le label fondprogress
    'si fondprogress est moins  haut que largealors ce sera le mode horizontal sinon vertical
    sens = IIf(usf.fondprogress.Height < maform.fondprogress.Width, "horizontal", "vertical")
 
    ' on memorise la largeur et hauteur   variable qui vont nous servir a manipuler le "Slider "
    largeur = maform.fondprogress.Width - 2
    hauteur = maform.fondprogress.Height - 2
 
    ' au cas ou progress existerait deja on la vire du sheet
    Dim shapo As Shape
    For Each shapo In ActiveSheet.Shapes
        If shapo.Name = "progress" Then shapo.Delete
    Next
    'on ajoute une forme dans le sheets( provisoirement)
    With ActiveSheet.Shapes.AddShape(1, 10, 15, maform.fondprogress.Width + 100, maform.fondprogress.Height + 100)
        .Name = "progress"
        .Line.Visible = msoFalse
        .Fill.Visible = msoTrue
        '8 styles sont disponibles
        Select Case le_style
        Case XP
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=0, Green:=255, blue:=30)
        Case vista
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=60, Green:=230, blue:=100)
            couleur_slider = vbBlack
            couleur_cadre = 4210688
        Case XPcorporate
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=200, Green:=255, blue:=255)
            couleur_slider = vbWhite
            couleur_cadre = vbBlack
        Case lady
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=255, Green:=100, blue:=200)
            couleur_slider = &HFF80FF
            couleur_cadre = &HC0C0FF
        Case darkblue
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=100, Green:=120, blue:=180)
            couleur_slider = vbBlue
            couleur_cadre = 8388736
        Case blood
           '<VBA_INSPECTOR>
           '    <DEPRECATION>
           '        <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
           '        <ITEM>[xls]ChartColorFormat.RGB</ITEM>
           '        <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
           '    </DEPRECATION>
           '</VBA_INSPECTOR>
           .Fill.ForeColor.RGB = RGB(Red:=255, Green:=0, blue:=0)
               couleur_slider = &HC0&
            couleur_cadre = 8388736
        Case silver
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=255, Green:=255, blue:=255)
 
 
            '.Fill.PresetTextured 1
            couleur_slider = vbBlack
            couleur_cadre = vbWhite
 
        Case wood
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartFillFormat.PresetTextured</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.PresetTextured 23
            couleur_slider = vbBlack
            couleur_cadre = &H40C0&
            If sens = vertical Then .Rotation = 90
            GoTo suite    ' on saute l'etape du gradient puisque l'on a une texture
        Case blueseven
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartColorFormat.RGB</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.ForeColor.RGB = RGB(Red:=0, Green:=200, blue:=255)
            couleur_slider = vbWhite
            couleur_cadre = vbBlue
 
        Case le_style
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartFillFormat.PresetTextured</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            .Fill.PresetTextured le_style
couleur_slider = vbWhite
            couleur_cadre = vbBlack
 
        End Select
 
        If Not IsNumeric(le_style) Then
            'l 'effet tube sera vertical ou horizontal selon "sens"
            If sens = "vertical" Then
                '<VBA_INSPECTOR>
                '   <DEPRECATION>
                '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
                '       <ITEM>[xls]ChartFillFormat.OneColorGradient</ITEM>
                '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
                '   </DEPRECATION>
                '</VBA_INSPECTOR>
                .Fill.OneColorGradient msoGradientVertical, 4, 0.1
            '<VBA_INSPECTOR>
            '   <DEPRECATION>
            '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
            '       <ITEM>[xls]ChartFillFormat.OneColorGradient</ITEM>
            '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215357" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215357</a> /URL>
            '   </DEPRECATION>
            '</VBA_INSPECTOR>
            ElseIf sens <> "vertical" Then .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
            End If
        End If
 
    End With
suite:
    'on copie la forme dans le clipboard
    ActiveSheet.Shapes("progress").CopyPicture xlScreen, xlBitmap    'copie la selection dans le clipboard
    'prend l'image dans le cliboard
    Dim hCopy&: OpenClipboard 0&
    hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H8)
    CloseClipboard    ' ferme le cliboard
    If hCopy = 0 Then Exit Function    'si il y a rien on sort de la fonction
    Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Dim tIID As GUID, tPICTDEST As PICTDESC, Ret As Long
    Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
    If Ret Then Exit Function
    With tPICTDEST
        .cbSize = LenB(tPICTDEST)
        .picType = 1
        .hImage = hCopy
    End With
    'on créé le itmap
    Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
    If Ret Then Exit Function
    On Error GoTo 0
 
    'on ajoute le control image dans le userform a l'interieur du label "fondprogress"
    Set slider = usf.Controls.Add("Forms.Image.1", "PROGRESSBARRE", True)
    'on ajuste le slider en fonction du fondprogress et en fonction du sens determiné au depart de la fonction sur la condition _
     du width et du height de celui ci
    With slider
        '<VBA_INSPECTOR>
        '   <DEPRECATION>
        '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
        '       <ITEM>[mso]Assistant.Left</ITEM>
        '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215358" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215358</a> /URL>
        '   </DEPRECATION>
        '</VBA_INSPECTOR>
        .Left = usf.fondprogress.Left + 1
        '<VBA_INSPECTOR>
        '   <DEPRECATION>
        '       <MESSAGE>Potentially contains deprecated items in the object model</MESSAGE>
        '       <ITEM>[mso]Assistant.Top</ITEM>
        '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215358" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215358</a> /URL>
        '   </DEPRECATION>
        '</VBA_INSPECTOR>
        .Top = IIf(sens = "vertical", maform.fondprogress.Top + maform.fondprogress.Height - 2, maform.fondprogress.Top + 1)
        .Width = IIf(sens = "vertical", maform.fondprogress.Width - 2, 1)
        .Height = IIf(sens = "vertical", 1, maform.fondprogress.Height - 2)
        '<VBA_INSPECTOR>
        '   <REMOVED>
        '       <MESSAGE>Potentially contains removed items in the object model</MESSAGE>
        '       <ITEM>[mso]CommandBarButton.Picture</ITEM>
        '       <URL><a href="http://go.microsoft.com/fwlink/?LinkID=215358" target="_blank">http://go.microsoft.com/fwlink/?LinkID=215358</a> /URL>
        '   </REMOVED>
        '</VBA_INSPECTOR>
        .Picture = iPic
        .PictureSizeMode = 1
        .BorderColor = couleur_slider
    End With
 
    maform.fondprogress.BorderColor = couleur_cadre
    'on efface la forme provisoire que l'on a créé precedemant dans la feuille on en a plus besoin
    ActiveSheet.Shapes("progress").Delete
    ' on vide la memoire de ipic on en a plus besoins non plus 'limage est copiée dans le controlimage (slider)
    Set iPic = Nothing
 
End Function

En fait le problème c'est que je tourne sur une version Excel 10 64 bits.
Comment pourriez-vous rendre ce magnifique programme compatible avec Excel 64bits.

PS/ Sur mon deuxième ordi avec Excel 32bits tout marche nickel.

Bien cordialement

Erreur ProgressBar

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager