Creer un userform dynamique avec curseur Lien hypertexte

**fred65200** · 29/01/2009, 22h09

Le code suivant crée dynamiquement un userform avec une image, un curseur perso pour suivre les liens hypertextes,
en prime un roulement de tambour à l'ouverture (si fichier présent sur le Disque dur).
Les images sont créées dans le répertoire temporaire et supprimées ensuite.
Mettre la ligne ThisWorkbook.VBProject.VBComponents.Remove ufTemp en commentaire pour accéder au code dans le userform (ufFred65200).

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
'---------------------------------------------------------------------------------------
' Module    : modCreerUfFred65200
' Auteur    : fred65200
' Date      : 29/01/2009
'---------------------------------------------------------------------------------------
 
Option Explicit
'CODE À PLACER DANS UN MODULE
Sub Creer_ufFred65200()
Dim ufTemp As Object
Dim mewObj As Object
Dim strCode As String
Dim i As Long
Const NomUSF = "ufFred65200"
 
On Error Resume Next
With ThisWorkbook.VBProject
    .VBComponents.Remove .VBComponents(NomUSF)
End With
On Error GoTo 0
 
ThisWorkbook.Save  ' si USF était déjà présent
 
Set ufTemp = Nothing
 
'Ajout du USF
Set ufTemp = ThisWorkbook.VBProject.VBComponents.Add(3)
 
'Attribution d'un nom à l'USF
ufTemp.Properties("name") = NomUSF
 
'Creation des labels
For i = 1 To 7
    Set mewObj = ufTemp.Designer.Controls.Add("forms.label.1", "Label" & i)
Next
 
'Creation contrôle imagelist pour reçevoir le curseur des liens
Set mewObj = ufTemp.Designer.Controls.Add("MSCOMCTLlib.ImageListCtrl", "imagelist1")
 
'Creation contrôle image
Set mewObj = ufTemp.Designer.Controls.Add("forms.image.1", "imgFred65200")
'Set mewObj = ufTemp.Designer.Controls.Add("InternetExplorer.WebBrowser", "wb")
 
'Creation bouton Fermer
Set mewObj = ufTemp.Designer.Controls.Add("forms.commandbutton.1", "btnFermer")
 
'Code du USF
strCode = strCode & "Option Explicit" & vbLf
strCode = strCode & "" & vbLf
'Déclaration des variables, constante et APIs
    'Chemin du dossier Temps
    strCode = strCode & "Private Declare Function GetTempPath Lib ""kernel32"" _" & vbLf
    strCode = strCode & "    Alias ""GetTempPathA"" ( _" & vbLf
    strCode = strCode & "    ByVal nBufferLength As Long, _" & vbLf
    strCode = strCode & "    ByVal lpBuffer As String) As Long" & vbLf
    strCode = strCode & "" & vbLf
    'Fonction pour ouvrir Fichiers et Dossiers
    strCode = strCode & "Private Declare Function ShellExecute Lib ""shell32.dll"" _" & vbLf
    strCode = strCode & "    Alias ""ShellExecuteA"" ( _" & vbLf
    strCode = strCode & "    ByVal hWnd As Long, _" & vbLf
    strCode = strCode & "    ByVal lpOperation As String, _" & vbLf
    strCode = strCode & "    ByVal lpFile As String, _" & vbLf
    strCode = strCode & "    ByVal lpParameters As String, _" & vbLf
    strCode = strCode & "    ByVal lpDirectory As String, _" & vbLf
    strCode = strCode & "    ByVal nShowCmd As Long) As Long" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "Const MAX_PATH = 260" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "Dim CheminCurseur As String" & vbLf
    strCode = strCode & "Dim CheminImage As String" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "Dim tabImage As Variant" & vbLf
    strCode = strCode & "Dim tabCurseur As Variant" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "Dim i As Long" & vbLf
    strCode = strCode & "" & vbLf
'Fonction pour obtenir le chemin du dossier Temp
    strCode = strCode & "Private Function GetTemporyFolderPath() As String" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "Dim sBuffer As String" & vbLf
    strCode = strCode & "Dim RV As Long" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "sBuffer = String(MAX_PATH, Chr(0))" & vbLf
    strCode = strCode & "RV = GetTempPath(MAX_PATH, sBuffer)" & vbLf
    strCode = strCode & "GetTemporyFolderPath = Left(sBuffer, RV)" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "End Function" & vbLf
    strCode = strCode & "" & vbLf
    'Création des images dans le dossier Temp
    strCode = strCode & "Sub CreationImage()" & vbLf
    strCode = strCode & "Dim F As Integer" & vbLf
    strCode = strCode & "Dim b As Byte" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "CheminCurseur = GetTemporyFolderPath & ""CurseurMain.cur""" & vbLf
    strCode = strCode & "CheminImage = GetTemporyFolderPath & ""fred65200.gif""" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "tabImage = Array(""71"", ""73"", ""70"", ""56"", ""57"", ""97"", ""133"", ""0"", ""188"", ""0"", ""179"", ""12"", ""0"", ""0"", ""153"", ""51"", ""153"", ""153"", ""153"", ""255"", ""255"", ""255"", ""204"", ""204"", ""204"", ""0"", ""0"", ""0"", ""0"", ""51"", ""51"", ""0"", ""102"", ""51"", ""51"", ""51"", ""51"", ""102"", ""102"", ""102"", ""0"", ""51"", ""0"", ""51"", ""153"", ""51"", ""51"", ""204"", ""51"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""33"", ""249"", ""4"", ""1"", ""0"", ""0"", ""12"", ""0"", ""44"", ""0"", ""0"", ""0"", ""0"", ""133"", ""0"", ""188"", ""0"", ""0"", ""4"", ""255"", ""144"", ""201"", ""73"", ""171"", ""189"", ""56"", ""235"", ""205"", ""187"", ""255"", ""96"", ""40"", ""142"", ""100"", ""105"", ""158"", ""104"", ""170"", _" & vbLf
    strCode = strCode & "    ""174"", ""108"", ""235"", ""190"", ""112"", ""44"", ""207"", ""116"", ""109"", ""223"", ""120"", ""174"", ""239"", ""124"", ""239"", ""255"", ""192"", ""160"", ""112"", ""72"", ""44"", ""26"", ""143"", ""200"", ""164"", ""114"", ""201"", ""108"", ""58"", ""159"", ""208"", ""168"", ""116"", ""74"", ""173"", ""90"", ""175"", ""216"", ""172"", ""118"", ""75"", ""17"", ""12"", ""6"", ""2"", ""238"", ""239"", ""43"", ""9"", ""12"", ""16"", ""4"", ""2"", ""194"", ""28"", ""240"", ""138"", ""115"", ""232"", ""195"", ""33"", ""77"", ""79"", ""203"", ""17"", ""242"", ""3"", ""254"", ""61"", ""67"", ""215"", ""9"", ""7"", ""25"", ""116"", ""129"", ""124"", ""46"", ""115"", ""106"", ""18"", ""123"", ""29"", ""115"", ""129"", ""8"", ""8"", ""133"", ""39"", ""140"", ""145"", ""128"", ""1"", ""144"", ""36"", ""146"", ""41"", ""113"", ""132"", ""150"", _" & vbLf
    strCode = strCode & "    ""31"", ""105"", ""45"", ""135"", ""155"", ""156"", ""27"", ""128"", ""46"", ""1"", ""118"", ""120"", ""143"", ""162"", ""24"", ""164"", ""134"", ""116"", ""1"", ""142"", ""170"", ""23"", ""172"", ""30"", ""120"", ""121"", ""122"", ""142"", ""169"", ""21"", ""115"", ""184"", ""3"", ""177"", ""21"", ""179"", ""27"", ""169"", ""185"", ""191"", ""4"", ""23"", ""114"", ""106"", ""138"", ""190"", ""12"", ""195"", ""40"", ""204"", ""203"", ""122"", ""1"", ""140"", ""206"", ""98"", ""181"", ""121"", ""143"", ""184"", ""48"", ""115"", ""166"", ""200"", ""211"", ""89"", ""119"", ""19"", ""189"", ""183"", ""113"", ""48"", ""113"", ""105"", ""168"", ""213"", ""182"", ""183"", ""83"", ""221"", ""54"", ""120"", ""209"", ""4"", ""219"", ""128"", ""195"", ""184"", ""199"", ""236"", ""156"", ""181"", ""131"", ""226"", ""25"", ""238"", ""128"", ""158"", ""28"", ""152"", _" & vbLf
    strCode = strCode & "    ""162"", ""252"", ""0"", ""82"", ""71"", ""193"", ""145"", ""45"", ""102"", ""142"", ""6"", ""125"", ""0"", ""200"", ""231"", ""144"", ""61"", ""12"", ""181"", ""202"", ""216"", ""65"", ""20"", ""106"", ""25"", ""134"", ""109"", ""80"", ""240"", ""209"", ""17"", ""132"", ""168"", ""196"", ""156"", ""47"", ""120"", ""255"", ""20"", ""74"", ""144"", ""134"", ""109"", ""216"", ""161"", ""37"", ""135"", ""6"", ""230"", ""154"", ""35"", ""171"", ""88"", ""10"", ""120"", ""219"", ""134"", ""117"", ""180"", ""128"", ""102"", ""130"", ""191"", ""34"", ""33"", ""41"", ""9"", ""98"", ""118"", ""19"", ""5"", ""40"", ""11"", ""220"", ""140"", ""217"", ""156"", ""9"", ""36"", ""100"", ""197"", ""12"", ""114"", ""126"", ""29"", ""165"", ""240"", ""109"", ""209"", ""82"", ""52"", ""1"", ""162"", ""178"", ""92"", ""229"", ""50"", ""200"", ""174"", ""13"", _" & vbLf
    strCode = strCode & "    ""12"", ""35"", ""50"", ""0"", ""86"", ""208"", ""14"", ""136"", ""170"", ""76"", ""15"", ""8"", ""24"", ""59"", ""128"", ""235"", ""80"", ""33"", ""122"", ""130"", ""137"", ""100"", ""144"", ""178"", ""31"", ""199"", ""135"", ""64"", ""101"", ""181"", ""25"", ""43"", ""192"", ""212"", ""5"", ""140"", ""65"", ""224"", ""254"", ""156"", ""32"", ""231"", ""204"", ""129"", ""104"", ""26"", ""150"", ""106"", ""72"", ""70"", ""129"", ""0"", ""200"", ""53"", ""189"", ""46"", ""248"", ""41"", ""10"", ""34"", ""113"", ""162"", ""190"", ""122"", ""204"", ""154"", ""72"", ""27"", ""55"", ""237"", ""84"", ""11"", ""12"", ""121"", ""36"", ""245"", ""208"", ""235"", ""149"", ""57"", ""9"", ""253"", ""4"", ""147"", ""0"", ""171"", ""65"", ""242"", ""231"", ""31"", ""53"", ""55"", ""188"", ""147"", ""199"", ""19"", ""239"", ""75"", ""209"", ""186"", _" & vbLf
    strCode = strCode & "    ""72"", ""131"", ""150"", ""205"", ""131"", ""246"", ""227"", ""211"", ""138"", ""139"", ""141"", ""123"", ""185"", ""144"", ""118"", ""79"", ""31"", ""102"", ""25"", ""189"", ""11"", ""76"", ""40"", ""33"", ""92"", ""13"", ""195"", ""141"", ""129"", ""189"", ""204"", ""84"", ""242"", ""142"", ""212"", ""35"", ""103"", ""17"", ""197"", ""92"", ""177"", ""214"", ""241"", ""230"", ""184"", ""43"", ""160"", ""73"", ""117"", ""21"", ""243"", ""116"", ""224"", ""141"", ""122"", ""66"", ""95"", ""213"", ""13"", ""93"", ""186"", ""99"", ""127"", ""234"", ""149"", ""14"", ""244"", ""187"", ""176"", ""237"", ""30"", ""214"", ""129"", ""194"", ""254"", ""206"", ""33"", ""234"", ""232"", ""129"", ""251"", ""156"", ""31"", ""97"", ""30"", ""23"", ""7"", ""127"", ""160"", ""244"", ""37"", ""161"", ""223"", ""255"", ""123"", ""228"", ""4"", ""184"", ""76"", ""123"", _" & vbLf
    strCode = strCode & "    ""75"", ""140"", ""215"", ""21"", ""28"", ""6"", ""102"", ""231"", ""196"", ""127"", ""108"", ""193"", ""6"", ""131"", ""115"", ""153"", ""61"", ""241"", ""159"", ""126"", ""49"", ""152"", ""134"", ""33"", ""19"", ""252"", ""25"", ""152"", ""33"", ""105"", ""14"", ""97"", ""1"", ""12"", ""129"", ""31"", ""6"", ""18"", ""143"", ""132"", ""80"", ""72"", ""183"", ""131"", ""57"", ""155"", ""189"", ""65"", ""138"", ""130"", ""54"", ""32"", ""200"", ""197"", ""118"", ""48"", ""214"", ""32"", ""35"", ""23"", ""3"", ""161"", ""232"", ""194"", ""110"", ""150"", ""228"", ""232"", ""83"", ""8"", ""60"", ""66"", ""210"", ""207"", ""117"", ""235"", ""129"", ""80"", ""33"", ""53"", ""110"", ""161"", ""112"", ""163"", ""114"", ""58"", ""90"", ""81"", ""78"", ""10"", ""16"", ""34"", ""181"", ""33"", ""22"", ""79"", ""250"", ""68"", ""34"", ""49"", _" & vbLf
    strCode = strCode & "    ""77"", ""86"", ""225"", ""71"", ""150"", ""165"", ""93"", ""233"", ""158"", ""151"", ""86"", ""132"", ""184"", ""208"", ""81"", ""65"", ""46"", ""83"", ""9"", ""85"", ""96"", ""86"", ""177"", ""17"", ""45"", ""127"", ""133"", ""97"", ""102"", ""116"", ""93"", ""213"", ""113"", ""212"", ""154"", ""66"", ""70"", ""169"", ""221"", ""29"", ""231"", ""156"", ""89"", ""225"", ""46"", ""39"", ""125"", ""105"", ""9"", ""35"", ""87"", ""230"", ""56"", ""13"", ""132"", ""151"", ""241"", ""180"", ""164"", ""136"", ""121"", ""96"", ""133"", ""31"", ""121"", ""45"", ""93"", ""68"", ""231"", ""27"", ""218"", ""180"", ""152"", ""155"", ""135"", ""28"", ""65"", ""244"", ""168"", ""24"", ""148"", ""144"", ""120"", ""168"", ""148"", ""221"", ""164"", ""84"", ""200"", ""46"", ""118"", ""73"", ""73"", ""194"", ""118"", ""28"", ""109"", ""58"", ""133"", ""29"", _" & vbLf
    strCode = strCode & "    ""2"", ""72"", ""42"", ""223"", ""8"", ""71"", ""14"", ""101"", ""167"", ""154"", ""29"", ""25"", ""248"", ""234"", ""164"", ""18"", ""110"", ""153"", ""102"", ""19"", ""139"", ""217"", ""212"", ""37"", ""7"", ""232"", ""92"", ""103"", ""199"", ""172"", ""80"", ""244"", ""9"", ""103"", ""165"", ""5"", ""157"", ""7"", ""141"", ""99"", ""255"", ""12"", ""100"", ""106"", ""19"", ""194"", ""206"", ""246"", ""199"", ""255"", ""90"", ""47"", ""76"", ""180"", ""172"", ""18"", ""91"", ""10"", ""97"", ""43"", ""176"", ""212"", ""122"", ""53"", ""132"", ""180"", ""216"", ""34"", ""209"", ""106"", ""15"", ""160"", ""76"", ""68"", ""133"", ""182"", ""68"", ""72"", ""155"", ""100"", ""20"", ""223"", ""246"", ""96"", ""238"", ""185"", ""79"", ""228"", ""58"", ""196"", ""54"", ""109"", ""201"", ""73"", ""100"", ""81"", ""83"", ""222"", ""32"", ""128"", _" & vbLf
    strCode = strCode & "    ""173"", ""207"", ""254"", ""49"", ""47"", ""124"", ""245"", ""218"", ""16"", ""110"", ""190"", ""249"", ""82"", ""134"", ""68"", ""153"", ""224"", ""2"", ""108"", ""176"", ""190"", ""3"", ""79"", ""27"", ""131"", ""64"", ""7"", ""55"", ""76"", ""238"", ""16"", ""238"", ""106"", ""182"", ""174"", ""195"", ""7"", ""27"", ""161"", ""112"", ""11"", ""12"", ""83"", ""172"", ""49"", ""165"", ""57"", ""56"", ""232"", ""239"", ""198"", ""32"", ""211"", ""177"", ""175"", ""12"", ""233"", ""238"", ""24"", ""242"", ""201"", ""117"", ""140"", ""252"", ""66"", ""196"", ""51"", ""196"", ""139"", ""242"", ""203"", ""242"", ""250"", ""231"", ""49"", ""11"", ""247"", ""194"", ""108"", ""179"", ""178"", ""253"", ""164"", ""167"", ""178"", ""145"", ""57"", ""195"", ""48"", ""192"", ""106"", ""55"", ""7"", ""125"", ""176"", ""192"", ""44"", ""200"", ""217"", ""47"", _" & vbLf
    strCode = strCode & "    ""103"", ""57"", ""9"", ""173"", ""52"", ""197"", ""68"", ""143"", ""26"", ""175"", ""152"", ""38"", ""212"", ""213"", ""150"", ""203"", ""75"", ""87"", ""253"", ""236"", ""168"", ""20"", ""239"", ""204"", ""0"", ""208"", ""86"", ""119"", ""221"", ""176"", ""170"", ""201"", ""130"", ""220"", ""102"", ""7"", ""63"", ""191"", ""66"", ""181"", ""215"", ""104"", ""167"", ""135"", ""34"", ""122"", ""48"", ""31"", ""0"", ""134"", ""155"", ""63"", ""227"", ""201"", ""118"", ""218"", ""116"", ""59"", ""188"", ""207"", ""217"", ""54"", ""207"", ""93"", ""247"", ""222"", ""27"", ""99"", ""128"", ""55"", ""223"", ""128"", ""7"", ""78"", ""219"", ""223"", ""130"", ""23"", ""78"", ""119"", ""156"", ""134"", ""39"", ""94"", ""248"", ""151"", ""138"", ""55"", ""206"", ""183"", ""171"", ""142"", ""71"", ""78"", ""119"", ""66"", ""57"", ""75"", ""110"", ""249"", _" & vbLf
    strCode = strCode & "    ""229"", ""152"", ""103"", ""110"", ""176"", ""255"", ""222"", ""154"", ""119"", ""142"", ""50"", ""225"", ""158"", ""135"", ""46"", ""250"", ""232"", ""164"", ""151"", ""110"", ""250"", ""233"", ""168"", ""167"", ""174"", ""250"", ""234"", ""172"", ""183"", ""238"", ""250"", ""235"", ""176"", ""199"", ""46"", ""251"", ""236"", ""180"", ""215"", ""110"", ""251"", ""237"", ""184"", ""231"", ""174"", ""251"", ""238"", ""188"", ""247"", ""238"", ""251"", ""239"", ""192"", ""7"", ""47"", ""252"", ""240"", ""196"", ""23"", ""111"", ""252"", ""241"", ""200"", ""39"", ""175"", ""252"", ""242"", ""204"", ""55"", ""239"", ""252"", ""243"", ""208"", ""163"", ""94"", ""64"", ""1"", ""6"", ""24"", ""80"", ""64"", ""29"", ""212"", ""87"", ""111"", ""125"", ""244"", ""26"", ""31"", ""144"", ""128"", ""1"", ""0"", ""0"", ""112"", ""61"", ""1"", ""9"", ""132"", ""31"", _" & vbLf
    strCode = strCode & "    ""254"", ""248"", ""220"", ""83"", ""156"", ""192"", ""247"", ""225"", ""39"", ""80"", ""128"", ""249"", ""226"", ""167"", ""15"", ""114"", ""1"", ""229"", ""155"", ""175"", ""128"", ""2"", ""241"", ""203"", ""15"", ""242"", ""250"", ""247"", ""223"", ""15"", ""64"", ""2"", ""250"", ""11"", ""153"", ""251"", ""10"", ""176"", ""128"", ""2"", ""2"", ""48"", ""128"", ""32"", ""107"", ""159"", ""1"", ""10"", ""104"", ""189"", ""233"", ""29"", ""16"", ""129"", ""0"", ""43"", ""223"", ""253"", ""12"", ""80"", ""190"", ""2"", ""22"", ""80"", ""1"", ""15"", ""132"", ""224"", ""31"", ""234"", ""119"", ""191"", ""5"", ""0"", ""224"", ""0"", ""10"", ""176"", ""96"", ""6"", ""53"", ""72"", ""135"", ""250"", ""1"", ""160"", ""131"", ""11"", ""160"", ""160"", ""8"", ""73"", ""248"", ""135"", ""247"", ""217"", ""207"", ""130"", ""41"", ""36"", _" & vbLf
    strCode = strCode & "    ""160"", ""7"", ""89"", ""88"", ""135"", ""1"", ""78"", ""239"", ""134"", ""55"", ""100"", ""95"", ""254"", ""104"", ""200"", ""195"", ""30"", ""250"", ""240"", ""135"", ""64"", ""12"", ""162"", ""16"", ""135"", ""72"", ""196"", ""34"", ""26"", ""241"", ""136"", ""72"", ""76"", ""162"", ""18"", ""151"", ""200"", ""196"", ""38"", ""58"", ""241"", ""137"", ""80"", ""140"", ""162"", ""20"", ""167"", ""72"", ""197"", ""42"", ""90"", ""241"", ""138"", ""88"", ""108"", ""34"", ""232"", ""126"", ""120"", ""128"", ""8"", ""1"", ""0"", ""0"", ""59"", ""0"")" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "tabCurseur = Array(""0"", ""0"", ""2"", ""0"", ""1"", ""0"", ""32"", ""32"", ""2"", ""0"", ""12"", ""0"", ""5"", ""0"", ""48"", ""1"", ""0"", ""0"", ""22"", ""0"", ""0"", ""0"", ""40"", ""0"", ""0"", ""0"", ""32"", ""0"", ""0"", ""0"", ""64"", ""0"", ""0"", ""0"", ""1"", ""0"", ""1"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""1"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""2"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""255"", ""255"", ""255"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""7"", ""248"", ""0"", ""0"", _" & vbLf
    strCode = strCode & "    ""7"", ""248"", ""0"", ""0"", ""15"", ""252"", ""0"", ""0"", ""15"", ""252"", ""0"", ""0"", ""31"", ""252"", ""0"", ""0"", ""31"", ""254"", ""0"", ""0"", ""63"", ""254"", ""0"", ""0"", ""47"", ""254"", ""0"", ""0"", ""111"", ""254"", ""0"", ""0"", ""239"", ""254"", ""0"", ""0"", ""207"", ""246"", ""0"", ""0"", ""13"", ""182"", ""0"", ""0"", ""13"", ""180"", ""0"", ""0"", ""13"", ""176"", ""0"", ""0"", ""13"", ""128"", ""0"", ""0"", ""12"", ""0"", ""0"", ""0"", ""12"", ""0"", ""0"", ""0"", ""12"", ""0"", ""0"", ""0"", ""12"", ""0"", ""0"", ""0"", ""12"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""0"", ""255"", _" & vbLf
    strCode = strCode & "    ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""248"", ""7"", ""255"", ""255"", ""240"", ""3"", ""255"", ""255"", ""240"", ""3"", ""255"", ""255"", ""224"", ""1"", ""255"", ""255"", ""224"", ""1"", ""255"", ""255"", ""192"", ""1"", ""255"", ""255"", ""192"", ""0"", ""255"", ""255"", ""128"", ""0"", ""255"", ""255"", ""128"", ""0"", ""255"", ""255"", ""0"", ""0"", ""255"", ""254"", ""0"", ""0"", ""255"", ""254"", ""0"", ""0"", ""255"", ""255"", ""32"", ""0"", ""255"", ""255"", ""224"", ""1"", ""255"", ""255"", ""224"", ""3"", ""255"", ""255"", ""224"", ""7"", ""255"", ""255"", ""224"", ""63"", ""255"", ""255"", ""225"", ""255"", ""255"", ""255"", ""225"", ""255"", ""255"", ""255"", ""225"", ""255"", ""255"", ""255"", _" & vbLf
    strCode = strCode & "    ""225"", ""255"", ""255"", ""255"", ""243"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""255"", ""0"")" & vbLf
    strCode = strCode & "" & vbLf
    'Creation du curseur
    strCode = strCode & "'Creation du curseur" & vbLf
    strCode = strCode & "F = FreeFile" & vbLf
    strCode = strCode & "Open CheminCurseur For Binary Access Write As F" & vbLf
    strCode = strCode & "    For i = 0 To UBound(tabCurseur)" & vbLf
    strCode = strCode & "        b = tabCurseur(i)" & vbLf
    strCode = strCode & "        Put #F, , b" & vbLf
    strCode = strCode & "        DoEvents" & vbLf
    strCode = strCode & "    Next" & vbLf
    strCode = strCode & "Close F" & vbLf
    'Création de l'image fred65200.gif
    strCode = strCode & "'Création de l'image fred65200.gif" & vbLf
    strCode = strCode & "F = FreeFile" & vbLf
    strCode = strCode & "Open CheminImage For Binary Access Write As F" & vbLf
    strCode = strCode & "    For i = 0 To UBound(tabImage)" & vbLf
    strCode = strCode & "        b = tabImage(i)" & vbLf
    strCode = strCode & "        Put #F, , b" & vbLf
    strCode = strCode & "        DoEvents" & vbLf
    strCode = strCode & "    Next" & vbLf
    strCode = strCode & "Close F" & vbLf
    strCode = strCode & "End Sub" & vbLf
    strCode = strCode & "" & vbLf
'Code btnFermer_Click()
strCode = strCode & "Private Sub btnFermer_Click()" & vbLf
strCode = strCode & "    Unload Me" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "" & vbLf
'Code Label4_Click()
strCode = strCode & "Private Sub Label4_Click()" & vbLf
strCode = strCode & "   ShellExecute 0&, vbNullString, Label4.Tag, vbNullString, vbNullString, 1" & vbLf
strCode = strCode & "   Label4.ForeColor = &H800080" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "" & vbLf
'Code Label6_Click()
strCode = strCode & "Private Sub Label6_Click()" & vbLf
strCode = strCode & "   Shell ""EXPLORER /select,c,"" & ThisWorkbook.FullName, vbNormalFocus" & vbLf
strCode = strCode & "   Label6.ForeColor = &H800080" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "" & vbLf
'Code UserForm_Click()
strCode = strCode & "Private Sub UserForm_Click()" & vbLf
strCode = strCode & "    Unload Me" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "" & vbLf
'Code UserForm_Initialize()
strCode = strCode & "Private Sub UserForm_Initialize()" & vbLf
    'Création des images
    strCode = strCode & "'Création des images" & vbLf
    strCode = strCode & "CreationImage" & vbLf
    'Initialisation des variables
    strCode = strCode & "'Initialisation des variables" & vbLf
    strCode = strCode & "Dim L1 As Long, L2 As Long, L3 As Long" & vbLf
    strCode = strCode & "'insertion du curseur à l'ImageList" & vbLf
    strCode = strCode & "ImageList1.ListImages.Add , ""CurseurMain"", LoadPicture(CheminCurseur)" & vbLf
    'Roulement de tambour
    strCode = strCode & "'Roulement de tambour" & vbLf
    strCode = strCode & "Application.ExecuteExcel4Macro _" & vbLf
    strCode = strCode & "    ""SOUND.PLAY( ,"""""" & Application.Path & ""\MEDIA\DRUMROLL.WAV"""")""" & vbLf
    'Image de gauche
    strCode = strCode & "'Image de gauche" & vbLf
    strCode = strCode & "With imgFred65200" & vbLf
    strCode = strCode & "   .PictureSizeMode = 0: .AutoSize = True" & vbLf
    strCode = strCode & "   .Picture = LoadPicture(CheminImage)" & vbLf
    strCode = strCode & "   .Left = 6" & vbLf
    strCode = strCode & "   .Top = 6" & vbLf
    strCode = strCode & "   .BorderStyle = 0 'fmBorderStyleNone" & vbLf
    strCode = strCode & "   .ControlTipText = ""Hello""" & vbLf
    strCode = strCode & "   .ZOrder (0)" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label Nom du classeur
    strCode = strCode & "'Label Nom du classeur" & vbLf
    strCode = strCode & "With Label1" & vbLf
    strCode = strCode & "   .AutoSize = True: .WordWrap = False" & vbLf
    strCode = strCode & "   .Caption = ThisWorkbook.Name" & vbLf
    strCode = strCode & "   .Top = 10: .Left = imgFred65200.Left + imgFred65200.Width + 6" & vbLf
    strCode = strCode & "   .Font.Bold = True" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label - réalisée par :
    strCode = strCode & "'Label - réalisée par :" & vbLf
    strCode = strCode & "With Label2" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Caption = ""- réalisée par :""" & vbLf
    strCode = strCode & "   .Top = Label1.Top + Label1.Height + 10" & vbLf
    strCode = strCode & "   .Left = Label1.Left" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label Frédéric Chapin - (fred65200)
    strCode = strCode & "'Label Frédéric Chapin - (fred65200)" & vbLf
    strCode = strCode & "With Label3" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Caption = ""Frédéric Chapin"" & vbLf & ""(fred65200)""" & vbLf
    strCode = strCode & "   .Top = Label2.Top + Label2.Height" & vbLf
    strCode = strCode & "   .Left = Label1.Left + 12" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label Email
    strCode = strCode & "'Label Email" & vbLf
    strCode = strCode & "With Label4" & vbLf
    strCode = strCode & "   .Caption = ""Email""" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Left = Label3.Left" & vbLf
    strCode = strCode & "   .Top = Label3.Top + Label3.Height" & vbLf
    strCode = strCode & "   .Tag = ""mailto:fred65200 <fredchapin@gmail.com>?Subject="" & _" & vbLf
    strCode = strCode & "        ThisWorkbook.Name & ""&Body=Bonjour "" & Application.UserName & "","" & _" & vbLf
    strCode = strCode & "        ""&body= Il y a un problème avec le classeur "" & ThisWorkbook.Name & "" ?""" & vbLf
    strCode = strCode & "   .Font.Underline = True" & vbLf
    strCode = strCode & "   .ForeColor = &HFF0000" & vbLf
    strCode = strCode & "   .MousePointer = 99 'fmMousePointerCustom ' curseur perso (pas de main dans les curseurs par défaut)" & vbLf
    strCode = strCode & "   .MouseIcon = ImageList1.ListImages(""CurseurMain"").Picture 'curseur stocké dans le imageList" & vbLf
    strCode = strCode & "   .TextAlign = 3" & vbLf
    strCode = strCode & "   .ControlTipText = ""Cliquez ici pour m'envoyer un courriel.""" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label - installée dans :
    strCode = strCode & "'Label - installée dans :" & vbLf
    strCode = strCode & "With Label5" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Caption = ""- installée dans :""" & vbLf
    strCode = strCode & "   .Top = Label4.Top + Label4.Height + 10" & vbLf
    strCode = strCode & "   .Left = Label1.Left" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label chemin du classeur
    strCode = strCode & "'Label chemin du classeur" & vbLf
    strCode = strCode & "With Label6" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Caption = ThisWorkbook.Path" & vbLf
    strCode = strCode & "   .Top = Label5.Top + Label5.Height" & vbLf
    strCode = strCode & "   .Left = Label3.Left" & vbLf
    strCode = strCode & "   .Font.Underline = True" & vbLf
    strCode = strCode & "   .ForeColor = &HFF0000" & vbLf
    strCode = strCode & "   .MousePointer = 99 'fmMousePointerCustom ' curseur perso (pas de main dans les curseurs par défaut)" & vbLf
    strCode = strCode & "   .MouseIcon = ImageList1.ListImages(""CurseurMain"").Picture 'curseur stocké dans le imageList" & vbLf
    strCode = strCode & "   .ControlTipText = ""Cliquez ici pour ouvrir le dossier.""" & vbLf
    strCode = strCode & "End With" & vbLf
    'Label Un projet sur Excel, contactez-moi.
    strCode = strCode & "'Label Un projet sur Excel, contactez-moi." & vbLf
    strCode = strCode & "With Label7" & vbLf
    strCode = strCode & "   .WordWrap = False: .AutoSize = True" & vbLf
    strCode = strCode & "   .Caption = ""Besoin d'aide sur Excel, contactez-moi.""" & vbLf
    strCode = strCode & "   .Caption = ""Un projet sur Excel, contactez-moi.""" & vbLf
    strCode = strCode & "   .Top = Label6.Top + Label6.Height + 10" & vbLf
    strCode = strCode & "   .Left = Label3.Left" & vbLf
    strCode = strCode & "   .Font.Bold = True" & vbLf
    strCode = strCode & "   .ForeColor = &H8000&" & vbLf
    strCode = strCode & "   .ControlTipText = ""En cliquant sur email.""" & vbLf
    strCode = strCode & "End With" & vbLf
    'Dimension du UF
    strCode = strCode & "'Dimension du UF" & vbLf
    strCode = strCode & "L1 = Label1.Left + Label1.Width + 10" & vbLf
    strCode = strCode & "L2 = Label6.Left + Label6.Width + 10" & vbLf
    strCode = strCode & "L3 = Label7.Left + Label7.Width + 10" & vbLf
    strCode = strCode & "Me.Caption = ""À propos...""" & vbLf
    strCode = strCode & "Me.Height = imgFred65200.Top + imgFred65200.Height + 25" & vbLf
    strCode = strCode & "Me.Width = Application.Max(L1, L2, L3)" & vbLf
    'Bouton Fermer
    strCode = strCode & "'Bouton Fermer" & vbLf
    strCode = strCode & "With btnFermer" & vbLf
    strCode = strCode & "   .Caption = ""Fermer""" & vbLf
    strCode = strCode & "   .Accelerator = ""F""" & vbLf
    strCode = strCode & "   .AutoSize = True: .WordWrap = False" & vbLf
    strCode = strCode & "   .Top = imgFred65200.Top + imgFred65200.Height - .Height" & vbLf
    strCode = strCode & "   .Left = Application.Max(L1, L2, L3) - .Width - 10" & vbLf
    strCode = strCode & "End With" & vbLf
    'Destruction des fichier images
    strCode = strCode & "'Destruction des fichier images" & vbLf
    strCode = strCode & "Kill CheminCurseur" & vbLf
    strCode = strCode & "Kill CheminImage" & vbLf
    strCode = strCode & "" & vbLf
    strCode = strCode & "End Sub" & vbLf
    'Son à la fermeture
    strCode = strCode & "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)" & vbLf
    strCode = strCode & "Application.ExecuteExcel4Macro _" & vbLf
    strCode = strCode & "    ""SOUND.PLAY( ,"""""" & Application.Path & ""\MEDIA\CHIMES.WAV"""")""" & vbLf
strCode = strCode & "End Sub" & vbLf
 
'Ajout de code au module
With ufTemp.CodeModule
    On Error Resume Next
    .DeleteLines 1 'si Option Explicit
    On Error GoTo 0
    .InsertLines 1, strCode
End With
 
VBA.UserForms.Add(ufTemp.Name).Show
'Mettre la ligne suivante en commentaire pour voir le code dans le USF (REM ou ')
ThisWorkbook.VBProject.VBComponents.Remove ufTemp
 
'Application.VBE.CommandBars.FindControl(ID:=106).Execute 'pas utile sur PC
Set ufTemp = Nothing
 
End Sub

**ankoubzh** · 17/05/2009, 11h01

Bonjour !
Merci pour ton code, qui m'a été très utile pour comprendre le fonctionnement de la création dynamique d'un userform.
En m'en insiprant, j'ai codé la la création dynamique d'un userform qui affiche dans des textbox les valeurs d'un tableau à taille variable (d'où la nécessité de dynamique)
par contre j'ai un petit souci technique : si l'userform qui doit être crée existe déjà, même si dans le code j'ai inclus :

Code :

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

1
2
3
4
On error resume next
with thisworkbook.vbproject
    .vbcomponents.remove .vbcomponents(NomUSF)
end with

comme cela est écrit dans le code-tutoriel, la première exécution de la macro me donne une erreur : l'objet existe déjà. ET, si je réexécute une nouvelle fois la macro directement, cela fonctionne très bien. L'userform est bien supprimé la première fois, mais cela fait comme si vb ne s'en rendait pas compte avant de relancer une nouvelle macro...
comment modifier cela ?
par ailleurs, est-ce indispensable de sauvegarder le workbook à chaque exécution de la macro (le mien commence à être particulièrement volumineux, et donc la macro particulièrement longue...)
Merci !

Creer un userform dynamique avec curseur Lien hypertexte

Contribuez

Discussions similaires

Partager

Partager