Une progressbar perso façon patosch

**patricktoulon** · 13/10/2012, 19h46

bonsoir a tous

me revoilà encore avec une petite astuce bien sympathique

une progressbar est le plus souvent utilisée pour avoir un aperçu graphique de l'évolution d'une macro ou fonction parfois simplement pour quantifier un nombre (gauge)

cela dit il arrive que ce satané microsoft controls 6.0 machin truc est absent sur certaines machine et là, bug dans les références, on a un "Manquant....."
d'autant plus que ce contrôle n'est pas super beau

je vous propose donc aujourd'hui une progressbar perso dans vos userform
facon vista ou seven et meme mieux

le principe
vous n'avez qu'a placer un label transparent avec bordure de la couleur de votre choix ,supprimer le texte de la caption
la taille et l'endroit que vous voulez dans le USERFORM
ce label doit s'appeler imperativement "fondprogress"
le code se charge du reste

voici le code de la fonction suivi de comment on s'en sert

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
'"""""""""""""""""""""""""""MODULE POUR INSERER UNE PROGRESSBARRE PERSO""""""""""""""""""""""""""""""
'                                                                                                   "
'                                creation patrick toulon                                             "
'                                                                                                   "
'                               Theme : personnalisation des applications                            "
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
 
Option Explicit
 
'je les met en constante afin de ne pas avoir a mettre les Guillemets quand on l'injecte en argument dans l'appel a la fonction
Public Const blue seven = "blue seven"
Public Const wood = "wood"
Public Const blood = "blood"
Public Const dark blue = "dark blue"
Public Const lady = "lady"
Public Const XP corporate = "XP corporate"
Public Const vista = "vista"
Public Const XP = "XP"
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
    Image As Long
End Type
Public Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long)
Public Declare Function Empty Clipboard Lib "User32" () As Long
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat%)
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMam 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
Public slider As Object
Public largeur As Long
Public iPic As IPicture
 
'on prend un cliché on en fait un bitmap
Public Function progress_bar_perso(usf, lefond As Object, Optional le_style As String = "vista")
    usf.fondprogress.BackStyle = 0
 
    On Error Resume Next
 
    largeur = lefond.Width - 2
    Dim shapo As Shape
    Dim stylos As String
    For Each shapo In ActiveSheet.Shapes
        If shapo.Name = "progress" Then shapo.Delete
    Next
    'on ajoute une forme dans le sheets( provisoirement)8 styles sont disponibles
    With ActiveSheet.Shapes.AddShape(1, 10, 15, 500, 50)
        .Name = "progress"
        .Line.Visible = msoFalse
        .Fill.Visible = msoTrue
        Select Case le_style
        Case "XP"
            .Fill.ForeColor.RGB = 45 & 70 & 90
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.3
        Case "vista"
            .Fill.ForeColor.RGB = 170 & 150 & 80
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "XPcorporate"
            .Fill.ForeColor.RGB = 145 & 200 & 255
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "lady"
            .Fill.ForeColor.RGB = 75 & 200 & 255
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "darkblue"
            .Fill.ForeColor.RGB = 75 & 120 & 200
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "blood"
            .Fill.ForeColor.RGB = 75 & 120 & 123
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "wood"
            .Fill.ForeColor.RGB = 75 & 120 & 47
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        Case "blueseven"
            .Fill.ForeColor.RGB = 130 & 140 & 255
            .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        End Select
    End With
 
    '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 = Len(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)
 
    With slider
        .Left = usf.fondprogress.Left + 1
        .Top = usf.fondprogress.Top + 1
        .Width = usf.fondprogress.Width - 2
        .Height = usf.fondprogress.Height - 2
        .Picture = iPic
        .PictureSizeMode = 1
    End With
    'on efface la forme provisoire que l'on a créé precedemant dans la feuille on en a plus besoin
    ActiveSheet.Shapes("progress").Delete
End Function

et voici ce que l'on doit mettre dans l'evenement d'une macro ou selui d'un
control

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
sub decompte ()
Dim fin As Long
'si la derniere variable est omis ce sera la facon vista
    progress_bar_perso Me, fondprogress, blood    'ou une des variable theme
'la variable largeur a été instruite dans l'appel a la fonction par le label"fondprogress"
        fin = 5000
    For i = 1 To fin
        slider.Width = (largeur / fin) * i
           Next
    slider.Width = 0

voili voilou
veuillez noter que vous avez le choix entre 8 teintes et libre a vous d'en ajouter

elle est pas belle ma progressbar

qu'en pensez vous ?

**vieuxmonsieur** · 14/10/2012, 01h13

Bonjour patrick,
Serait-il possible d'avoir un petit classeur démo ?
En te remerciant.

**kiki29** · 14/10/2012, 01h23

Salut,

elle est pas belle ma progressbar

Quel exhibitionniste !

**patricktoulon** · 14/10/2012, 16h57

bonjour kiki29

Quel exhibitionniste !

tant que je suis pas tout nu ça va

bonjour petit vieux je ne vois pas l'intérêt de mettre un exemplaire tout est dans le code tu n'a cas copier coller

bon comme vous êtes gentils je l'ai un peu amélioré
voila maintenant que que la fonction gère le mode verticale ou horizontale
toute seule rien a faire
en fait des le départ si le width ....... oh et puis le code est largement commenté
voila le code dans un module standard:

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
 
'"""""""""""""""""""""""""""MODULE POUR INSERER UNE PROGRESSBARRE PERSO""""""""""""""""""""""""""""""
'                                                                                                   "
'                                création patrick toulon                                             "
'                                                                                                   "
'                               Thème : personnalisations des applications                            "
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
 
Option Explicit
 
'je les met en constante afin de ne pas avoir a mettre les Guillemets quand on l'injecte en argument dans l'appel a la fonction
Public Const blue seven = "blue seven"
Public Const wood = "wood"
Public Const blood = "blood"
Public Const dark blue = "dark blue"
Public Const lady = "lady"
Public Const XP corporate = "XP corporate"
Public Const vista = "vista"
Public Const XP = "XP"
Public Const vertical = "vertical"
 
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
    Image As Long
End Type
Public Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long)
Public Declare Function Empty Clipboard Lib "User32" () As Long
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat%)
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMam 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" (pict Disc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Public slider As Object
Public largeur As Long
Public hauteur As Long
Public maform As Object
Public iPicAs IPicture
Public sens As Variant
'Public fin As Long
Public i As Long
Public e As Long
Function progression(e, fin)
    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
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
 
    usf.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 < usf.fondprogress.Width, "horizontal", "vertical")
 
    ' on memorise la largeur et hauteur   variable qui vont nous servir a manipuler le "Slider "
    largeur = usf.fondprogress.Width - 2
    hauteur = usf.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 + 30, maform.fondprogress.Height + 30)
        .Name = "progress"
        .Line.Visible = msoFalse
        .Fill.Visible = msoTrue
        '8 styles sont disponibles
        Select Case le_style
        Case "XP"
            .Fill.ForeColor.RGB = 45 & 70 & 90
        Case "vista"
            .Fill.ForeColor.RGB = 170 & 150 & 80
        Case "XPcorporate"
            .Fill.ForeColor.RGB = 145 & 200 & 255
        Case "lady"
            .Fill.ForeColor.RGB = 75 & 200 & 255
        Case "darkblue"
            .Fill.ForeColor.RGB = 75 & 120 & 200
        Case "blood"
            .Fill.ForeColor.RGB = 75 & 120 & 123
        Case "wood"
            .Fill.ForeColor.RGB = 75 & 120 & 47
        Case "blueseven"
            .Fill.ForeColor.RGB = 130 & 140 & 255
        End Select
        'l 'effet tube sera vertical ou horizontal selon "sens"
        If sens = "vertical" Then
            .Fill.OneColorGradient msoGradientVertical, 4, 0.1
        ElseIf sens <> "vertical" Then .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
        End If
    End With
 
    '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 = Len(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
        .Left = usf.fondprogress.Left + 1
        .Top = IIf(sens = "vertical", usf.fondprogress.Top + usf.fondprogress.Height - 2, usf.fondprogress.Top + 1)
        .Width = IIf(sens = "vertical", usf.fondprogress.Width - 2, 1)
        .Height = IIf(sens = "vertical", 1, usf.fondprogress.Height - 2)
        .Picture = iPic
        .PictureSizeMode = 1
    End With
    '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
    Set iPic = Nothing
End Function

et puis voila ce qu'il y a dans le userform( beaucoup de

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
vert ):mouarf::mouarf:
'variable  theme
'blueseven
'wood
'blood
'darkblue
'lady
'XPcorporate
'vista
'XP
 
'il suffit maintenant de metre "progression suivi de la variable incrementée et la limite finale de votre boucle , dans votre boucle
'comme ceci:
'progression variable incrementée en cour, limite
 
 
' la fonction fait tout toute seule la différence entre les mode verticale et horizontale ,ca!!! trop chouette
'en fonction de la forme du label "fongprogress" seul control obligatoire
' ne vous occupez pas de la couleur ou je ne sais quelle propriété du label la fonction ce charge de tout
 
 
Private Sub UserForm_Initialize()
'il suffit simplement maintenant d'appeler la fonction comme ceci "fonction userform,style" _
  et meme style est optionel si vous ne le mettez pas ce sera le style vista d'office
'les style sont listés en haut de module userform
    progress_bar_perso Me, blueseven
End Sub
Private Sub CommandButton1_Click()
 
    For i = 1 To 50000
        progression i, 50000
        DoEvents    ' ne pas oublié de mettre ce doevents sinon l'effet est trop rapide
    Next
End Sub

elle est pas belle ma progress barre ???,

heu........qu'en pensez vous

**patricktoulon** · 15/10/2012, 17h29

bonjour

allez quelques petites améliorations et options
OPtion:
verticale ou horizontal automatique
toutes les texture disponible pour les formes automatique sont disponible
de 1 a 22

les couleurs des bordures du label "fond progress" ainsi que celle du slider (progressbarre) se modifie en fonction du choix du style

le calcul se fait plus dans la boucle mais dans la fonction "progressbarre(X,Z)"

amélioration:
l'appel se fait des le activate ou le initalyse de l'userform
comme ceci

c'est commenté)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Private Sub UserForm_Initialize()

'il suffit simplement maintenant d'appeler la fonction comme ceci "progressbar perso userform,style" _
et même style est optionnel si vous ne le mettez pas ce sera le style vista d'office
'les style sont listés en haut de module userform

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
progressbar perso Me, 7  ' le chiffre 7 représente la 7eme texture disponible dans excel

OU bien comme çà

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
 'progressbar perso Me              ' la barre  style vista par défaut

OU bien comme çà

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
'progressbar perso Me ,blue seven ' thème blue seven
 
 
End Sub

ensuite dans une boucle for X to Z( par exemple )dans le userform ou un module standard

vous faite progresser la barre comme ceci:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
 
For i = 1 To 50000
        Progressbarre i, 50000 la fonction progressbarre suivi de la variable incrémentée et de la limite haute de la boucle 
 
 
    Next

voila et maintenant le code dans un module standard

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
 
'"""""""""""""""""""""""""""MODULE POUR INSERER UNE PROGRESSBARRE PERSO""""""""""""""""""""""""""""""
'                                                                                                   "
'                                création patrick toulon                                             "
'                                                                                                   "
'                               Thèmes : personnalisation des applications                            "
'""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
 
Option Explicit
 
'je les met en constante afin de ne pas avoir a mettre les Guillemets quand on l'injecte en argument dans l'appel a la fonction
Public Const blue seven = "blue seven"
Public Const wood = "wood"
Public Const blood = "blood"
Public Const dark blue = "dark blue"
Public Const lady = "lady"
Public Const XP corporate = "XP corporate"
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
    Image As Long
End Type
Public Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long)
Public Declare Function Empty Clipboard 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
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
 
 
'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.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
            .Fill.ForeColor.RGB = 45 & 70 & 90
        Case vista
            .Fill.ForeColor.RGB = 170 & 150 & 80
            couleur_slider = vbBlack
            couleur_cadre = 4210688
        Case XPcorporate
            .Fill.ForeColor.RGB = 145 & 200 & 255
            couleur_slider = vbWhite
            couleur_cadre = vbBlack
        Case lady
            .Fill.ForeColor.RGB = 75 & 200 & 255
            couleur_slider = &HFF80FF
            couleur_cadre = &HC0C0FF
        Case darkblue
            .Fill.ForeColor.RGB = 75 & 120 & 200
            couleur_slider = vbBlue
            couleur_cadre = 8388736
        Case blood
            .Fill.ForeColor.RGB = 90 & 120 & 160
            couleur_slider = &HC0&
            couleur_cadre = 8388736
        Case silver
            .Fill.PresetTextured 1
            couleur_slider = vbBlack
            couleur_cadre = vbWhite
 
        Case wood
            .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
            .Fill.ForeColor.RGB = 130 & 140 & 255
            couleur_slider = vbWhite
            couleur_cadre = vbBlue
 
        Case le_style
            .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
                .Fill.OneColorGradient msoGradientVertical, 4, 0.1
            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 = Len(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
        .Left = usf.fondprogress.Left + 1
        .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)
        .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

voila
bonne utilisation et merci pour les suggestions si vous en avez

au plaisir

**Vadorblanc** · 15/10/2012, 20h54

Bonjour patrick,
J'ai essayé de faire fonctionner ta progressbar qui est plutôt jolie, je t'ai bien voté, mais malgré tes explications ça ne marche pas...
Je suis comme vieuxmonsieur#2
Serait-il possible d'avoir un petit classeur démo ?
En te remerciant.

**patricktoulon** · 16/10/2012, 12h28

bonjour

je ne vois pas ce qui ne peut pas marcher

dis moi l'erreur ou le numéro d'erreur que tu a

et si je dépose pas d'exemplaire c'est parce que au niveau des pièces jointes je suis a bloc ce qui m'obligerais de supprimer une autre contribution

j'attend le retour je suis la jusqu'à 15 heures 30

cela dit encore une fois si vous avez bien suivi les consignes vous devriez avoir le même que mon model
tout le code qui est dans mon exemplaire est dans le code que j'ai posté

tiens voila on va faire un petit essai juste l'apparence pour voir
ferme tout tes fichierss
ouvre en un tout neuf
dans ce fichier met lui un userform et rien d'autre (pas de controls) ok
maintenant ouvre le module du userform
et met lui ce code et rien que ça tu devrai avoir l'aperçu de la progressbar

si tu ne vois rien c'est que tu a un souci au niveau de tes librairies

voila le code :

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
 
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(8) As Byte
End Type
 
Private Type PICTDESC
    cbSize As Long
    picType As Long
    hImage As Long
End Type
Private Declare Function OpenClipboard& Lib "User32" (ByVal hwnd As Long)
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard& Lib "User32" ()
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
Private iPic As IPicture
Private Sub UserForm_Activate()
 With ActiveSheet.Shapes.AddShape(1, 10, 15, 200, 200)
        .Name = "monimagesheets"
        .Line.Visible = monimage
        .Fill.Visible = msoTrue
   .Fill.ForeColor.RGB = 130 & 140 & 255
    .Fill.OneColorGradient msoGradientHorizontal, 4, 0.1
   .CopyPicture xlScreen, xlBitmap    'copie la selection dans le clipboard
 
   End With
 
    '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 Sub    '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 Sub
    With tPICTDEST
        .cbSize = Len(tPICTDEST)
        .picType = 1
        .hImage = hCopy
    End With
    'on créé le itmap
    Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
    If Ret Then Exit Sub
    On Error GoTo 0
 
    'on ajoute le control image dans le userform a l'interieur du label "fondprogress"
    Set monimageusf = Me.Controls.Add("Forms.Image.1", "toto", True)
    With monimageusf
        .Left = 20
        .Top = 20
        .Width = 300
        .Height = 20
        .Picture = iPic
        .PictureSizeMode = 1
        .BorderColor = vbRed
    End With
 monimageusf.PictureSizeMode = 1
Sheets(1).Shapes("monimagesheets").Delete
Set iPic = Nothing
End Sub

j'attend le retour comme ca apres je passe a autre chose

au plaisir

**vieuxmonsieur** · 17/10/2012, 12h14

bonjour,
je vous remercie de ne pas mettre un classeur exemple.

**patricktoulon** · 17/10/2012, 15h10

Bonjour vieuxmonsieur

je pense avoir été clair sur la raison de ne pas pouvoir mettre un exemplaire

cela dit j'ai pris la peine de poster un nouveau code spécialement pour vous

de façon a ce que vous essayez si visuellement vous obtenez une progressbar arrivé a terme de façon a plus ou moins déterminer votre problème

si le copier coller n'est pas a votre porté même un exemplaire ne vous servira a rien
citation du jour :

Qui peut le plus peut le moins

l'inverse est moins sur

au plaisir

**fring** · 17/10/2012, 17h57

Bonjour,

Pour info j'ai arrêté de tenter de le faire fonctionner ton premier code après les 5 premières erreurs...

Espace dans le nom des constantes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Public Const blue seven = "blue seven"
Public Const dark blue = "dark blue"
Public Const XP corporate = "XP corporate"

Espace dans la déclaration de la fonction EmptyClipboard

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Public Declare Function Empty Clipboard Lib "User32" () As Long

Conflit dans la déclaration des fonctions GetClipboardData, même nom pour deux fonctions

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat%)
Public Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMam As Long) As Long

**patricktoulon** · 17/10/2012, 19h20

bonsoir fring

les espaces n'y etait pas dans mon code il se sont mis au copier coller entre les deux balises codes

je rextifie ca tout de suite

non de dieu!....

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
 
 
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
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
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
 
 
'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
            .Fill.ForeColor.RGB = RGB(Red:=0, Green:=255, Blue:=30)
        Case vista
            .Fill.ForeColor.RGB = RGB(Red:=60, Green:=230, Blue:=100)
            couleur_slider = vbBlack
            couleur_cadre = 4210688
        Case XPcorporate
            .Fill.ForeColor.RGB = RGB(Red:=200, Green:=255, Blue:=255)
            couleur_slider = vbWhite
            couleur_cadre = vbBlack
        Case lady
            .Fill.ForeColor.RGB = RGB(Red:=255, Green:=100, Blue:=200)
            couleur_slider = &HFF80FF
            couleur_cadre = &HC0C0FF
        Case darkblue
            .Fill.ForeColor.RGB = RGB(Red:=100, Green:=120, Blue:=180)
            couleur_slider = vbBlue
            couleur_cadre = 8388736
        Case blood
           .Fill.ForeColor.RGB = RGB(Red:=255, Green:=0, Blue:=0)
               couleur_slider = &HC0&
            couleur_cadre = 8388736
        Case silver
            .Fill.ForeColor.RGB = RGB(Red:=255, Green:=255, Blue:=255)
 
 
            '.Fill.PresetTextured 1
            couleur_slider = vbBlack
            couleur_cadre = vbWhite
 
        Case wood
            .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
            .Fill.ForeColor.RGB = RGB(Red:=0, Green:=200, Blue:=255)
            couleur_slider = vbWhite
            couleur_cadre = vbBlue
 
        Case le_style
            .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
                .Fill.OneColorGradient msoGradientVertical, 4, 0.1
            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 = Len(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
        .Left = usf.fondprogress.Left + 1
        .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)
        .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

et le code 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
19
20
21
22
23
24
25
26
27
28
'couleurs posibles
'blueseven, wood , blood , darkblue , lady , XPcorporate , vista , XP , silver
'Ou!!! vous pouvez simplement metre un chiffre de 1 a 22 ces chiffres correspondants au textures disponibles d'excel
 
'POUR LA BOUCLE
'il suffit maintenant de metre "progressbarre suivi de la variable incrementée et la limite finale de votre boucle , dans votre boucle
'comme ceci:
'progressbarre variable incrementée en cour, limite
 
 
' la fonction fait tout toute seule la différence entre les mode verticale et horizontale ,ca!!! trop chouette
'en fonction de la forme du label "fongprogress" seul control obligatoire
' ne vous occupez pas de la couleur ou je ne sais quelle propriété du label la fonction ce charge de tout
 
 
Private Sub UserForm_Initialize()
'il suffit simplement maintenant d'appeler la fonction comme ceci "progress_bar_perso userform,style" _
  et meme style est optionel si vous ne le mettez pas ce sera le style vista d'office
'les style sont listés en haut de module userform
    progress_bar_perso Me, vista
    'progress_bar_perso Me              ' theme vista d'office
 
End Sub
Private Sub CommandButton1_Click()
    For i = 1 To 50000
        Progressbarre i, 50000
    Next
End Sub

dis moi que ca marche pas !!!! encore
purré ca cserait bien qu'il y en ai un qui arrive a la faire fonctionner quand meme

et puis zut de zut voi un le fichier demo comme ca on en parle plus

au plaisir

**patricktoulon** · 17/10/2012, 19h43

re

j'oubliais de dire que maintenant même les 22 textures sont disponibles
il suffit de mettre le numéro correspondant a la texture a la place de blueseven ou autre

essayez la demo peut ça vous parlera mieux

au plaisir

**fring** · 17/10/2012, 20h09

Ok ça fonctionne mais il y a une erreur sur cette ligne

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

progress_bar_perso Me, vista

le paramètre vista n'est pas une variable mais un string donc... --> "vista"

Ensuite c'est un jeu de piste pour arriver à le faire fonctionner... il faut déchiffrer le code pour trouver qu'il faut placer un label sur le UserForm et le nommer fondprogress.

Tu comprends peut être mieux maintenant pourquoi les gens te demandent de joindre un exemple qui fonctionne.

Puisque tu ne veux pas mettre un exemple, il faudrait expliquer ce qu'il y a lieu de faire :

créer un UserForm
ajouter un bouton
ajouter un label
d'autres points importants tels que le nom du Label, etc...
créer une procédure pour afficher le UserForm

sans ça ta contribution servira à peu de gens

Sinon le résultat est joli

**patricktoulon** · 17/10/2012, 20h32

re

non vista n'est pas une erreur

regarde dans le module standard il y est bien en const

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Public Const vista = "vista"

cela dit il est facultatif puisque le _style est optional et vista par défaut dans la fonction

et j'ai mis un exemple a disposition

quand au "fondprogress " je l'ai bien signalé dans les commentaire en haut du code du module de l'userform
et dans mes postes précédents
ici:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
' la fonction fait tout toute seule la différence entre les mode verticale et horizontale ,ça!!! trop chouette
'en fonction de la forme du label "fongprogress" seul control obligatoire
' ne vous occupez pas de la couleur ou je ne sais quelle propriété du label la fonction ce charge de tout

et dans le premier post
ici:

le principe
vous n'avez qu'a placer un label transparent avec bordure de la couleur de votre choix ,supprimer le texte de la caption
la taille et l'endroit que vous voulez dans le USERFORM
ce label doit s'appeler imperativement "fondprogress"
le code se charge du reste

enfin maintenant il y a un fichier demo j'ai réussi a vider tous ce qui ne concernait pas la progress bars

a tu essayé plusieurs thèmes

alors elle est pas jolie ?

merci pour le retour

au plaisir

**vieuxmonsieur** · 17/10/2012, 20h34

Bonjour à tous,
Je vous remercie pour cette démo.
Je me suis permis d'apporter une petite modification, j'espère que vous ne m'en voudrez pas.

Après :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Public Function progress_bar_perso(usf, Optional le_style As String = "vista")

J'ai mis :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.ScreenUpdating = False

et :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.ScreenUpdating = True

avant End Function

Cordialement.

**patricktoulon** · 17/10/2012, 20h44

bonsoir vieuxmonsieur

vous m'avez dit:

Bonjour à tous,
Je vous remercie pour cette démo.
Je me suis permis d'apporter une petite modification, j'espère que vous ne m'en voudrez pas.

Après :

Code :Sélectionner tout - Visualiser dans une fenêtre à partPublic Function progress_bar_perso(usf, Optional le_style As String = "vista")

c'est une erreur car le_style doit rester variant
car il peut contenir le chiffre 1 a 22 corespondant au index des texture disponible pour les formes automatiques excel

quand au screenupdating il sont pour moi inutile car quand je l'utilise je vois même pas la création de la forme sur le sheets par rapport a la vitesse de la fonction

cela dit vous pouvez rester tel quel sa vous enlève la possibilité de mettre une texture a la places des dégradés de couleur correspondant au thèmes

au plaisir

j'oubliais pour fring
le bouton dans le userform c'etait juste pour la demo

la macro du bouton devra etre lancée pour le calcul,ou une boucle"for x = a to z"sinon je ne vois pas l'utilité de cette progressbar si ce n'est que d'etre plus jolie que l'original c'est quand meme et avant tout une progressbarre

**fring** · 18/10/2012, 13h27

Envoyé par patricktoulon

re

non vista n'est pas une erreur

regarde dans le module standard il y est bien en const

Au temps pour moi, j'avais omis la déclaration des constantes

**pijaku** · 06/11/2014, 10h31

Bonjour Patrick, Le forum,

Rien à dire sur la progressbarre en elle-même, si ce n'est son nom. Barre de progression eut été de meilleur aloi ;-)
Chauvinisme quand tu nous tiens!

Par contre, ce qui me gène dans ta démo, c'est le DoEvents en boucle. Ce n'est pas particulièrement génant dans la démo en elle-même car tu ne boucles que 50 000 fois, mais j'imagine les effets produits sur une boucle beaucoup plus grande...

Je me suis permis donc de reprendre ton fichier et d'y intégrer un Timer. J'ai intégré, dans l'affichage des résultats, la durée afin de comparer ce qui est comparable...
Regardes-y lorsque tu auras un instant et dis moi ton sentiment.

En tout cas, je salue ton travail de recherche et de codage.

Bien cordialement,

Franck

**kelly27** · 06/11/2014, 20h11

Merci encore pour ce travail de maitre mis à disposition aussi généreusement.
J’ai finalement opté pour travailler avec Excel 32bits et le progresse barre marche très bien.
C'est hyper bluffant quand la barre progresse dans le formulaire. Chapeau aussi pour les textures et couleurs : j'ai opté pour la "Case Wood"

Néanmoins J’aurais deux demandes par rapport à ce programme :

1ére : Comment l’adapter à mon formulaire ? Sur des commandes boutons telles que « Importer » « supprimer » ou « modifier »
En fait je n’arrive pas synchroniser la barre de progression avec l’exécution de la macro.
Soit la barre de progression s’exécute avant la macro, soit elle s’exécute après la macro (en fonction d’où je l’ai placée). Comment faire pour que la barre démarre en début de macro, progresse le temps de la macro puis se termine en même temps que la macro suivie du message box de fin de l’action.

2éme : Apres son déroulement, la barre reste visible (bien sur elle reprend au début dès qu’il Ya une nouvelle commande). Est-ce qu’il ne serait pas mieux de la remettre automatiquement à 0 (invisible) à la fin de l’exécution de la macro. Par exemple quand on quitte le message box de fin de l’action.

J’espère que j’ai été assez claire dans mes explications. Le VBA est nouveau pour moi mais je progresse plutôt pas mal.
Merci beaucoup du temps passé à aider les novices.

Cordialement

**patricktoulon** · 06/11/2014, 21h54

Bonsoir

je ne sais pas que fait ta macro mais dans mon exemple je me sert d'une simple boucle
et dans cette boucle j'injecte l'item de la boucle et sa fin
la fonction de la progressbars fait le reste

en ce qui te concerne si ta macro fait des boucles sert toi de ca tout simplement

cette contribution commence a dater je vais la revoir en profondeur des que j'ai un moment notamment une adaptation en 64 bits sa me parait presque obligatoire aujourd'hui

Bonne utilisation

Une progressbar perso façon patosch

Contribuez

Discussions similaires

Partager

Partager