[XL-2003] problème webbrowser utilisation

trblolo · 30/06/2009, 19h52

Bonjour,

J'essai d'utiliser webbrowser afin de réaliser pendant l'exécution de mon code un petit défilement d'un gif animé.
Le problème est :
Quand mon userform1 se lance il affiche une case blanche sans le gif.
Le programme se déroule mais aucun gif.
Et a la fin de l'exécution de mon code le gif animé s'anime

J'aimerais si cela est possible avoir le gif animé pendant l'execution de mon code

merci d'avance

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
Private Sub UserForm_Activate()
Dim var As String
 
var = "d:\test.gif"
 
UserForm1.Repaint
 
'Version pour afficher l'image à sa taille réelle:
WebBrowser1.Navigate "ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG " & " SRC='" & var & "'</IMG></BODY></CENTER></HTML>"
 
 
 
 
deb:
Do While i <> 10000
Range("a1").Formula = "=" + CStr(i)
UserForm1.Caption = "test" + CStr(i)
i = i + 1
Loop
 
 
ENd Sub

mapeh · 30/06/2009, 20h05

Bonsoir,

Bien qu'il soit préférable de mettre le code d'insertion du gif dans l'Initialize de l'usf, tu peux essayer ceci :

Code :

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

1
2
3
4
5
.....
i = i + 1
DoEvents
Loop
....

et supprime le Repaint...

trblolo · 30/06/2009, 20h13

merci beaucoup sa fonctionne.

Pourquoi est ce mieux un initialize ?

Et a quoi sert le Doevents?

trblolo · 01/07/2009, 10h42

Bonjour,

Le programme précédent était un test pour connaître comment voir le gif s'animer.

En réalité j'ai un programme assez long qui contient plusieurs boucle, plusieurs appel a des sous fonctions.

J'ai essayé de mettre le DoeVENTS dans ce programme mais sa ne fonctionne pas.

Faut-il mettre un doevents a chaque boucles, ou un seul?
Y a t'il un endroit particulier pour mettre ce Doevents.

Et a quoi sert réellement ce Doevents ?

Merci pour votre aide !

Si il faut je mettrais mon code (il est assez long en fait).

Krovax · 01/07/2009, 10h57

Doevents permet au système de faire ce qu'il a a faire avant de continuer la macro. Tu doit donc en mettre un chaque fois que ton système a un truc a faire avant de continuer la macro (la je sent que ca va beaucoup t'aider

)
Regarde l'aide sur DoEvents pour plus d'info
L'avantage du initialize c'est que tu ne lance la macro qu'a l'ouverture, et pas a chaque fois que tu change de fenètre (si je me souviens bien)

Au passage la phrase

Citation:

J'ai essayé de mettre le DoeVENTS dans ce programme mais sa ne fonctionne pas.

Tu ne dit n'y ou ni ce qui ne fonctionne pas ca n'aide pas a t'aider

trblolo · 01/07/2009, 15h14

Voici mon code :

Pouvez vous m'aider a placer les DoEvents ?

En fait quand j'en place dans la boucle je ne vois pas mon gif s'animer, peut-on mettre plusieurs DoEvents ?

Merci d'avance

Code :

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

1
2
3
4
5
6
7
8
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" ( _
                 ByVal lpBuffer As String, _
                 nSize As Long) As Long
Sub auto_open()
 
UserForm1.Show
 
End Sub

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
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
Option Explicit
Option Base 1
 
Dim nomdossier As String
Dim Monclasseur As Variant
Dim nomclasseur As Variant
Dim recentDir As String
Dim h As Integer
Dim Tableau2()
'Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" ( _
                 ByVal lpBuffer As String, _
                 nSize As Long) As Long
 
Sub UserForm_Activate()
Dim Racine As String, var As String, nompc As String, x As Variant, finligne As Variant, fincolonne As Variant, nommacro As String
Dim modele, morpheeini, recherche5, recherche6, recherche7, recherche8, coordligne As Variant
 
'On Error GoTo error
 
var = "D:\Essais\COMMUN\panhard.gif"
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
WebBrowser1.Navigate "ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG " & " SRC='" & var & "'</IMG></BODY></CENTER></HTML>"
 
nompc = ComputerName
nompc = Right(nompc, 1)
 
'ouverture du fichier modele
 
morpheeini = "D:\Banc0" + nompc + "_Config\Morphee_panh0" + nompc + ".ini"
 
Workbooks.OpenText Filename:=morpheeini, Origin _
        :=xlWindows, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
        xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
        , Comma:=False, Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
        TrailingMinusNumbers:=True
 
coordligne = Cells.Find(What:="lasttest1", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Address
 
coordligne = Range(coordligne).Row
 
Rows("" + CStr(coordligne) + ":" + CStr(coordligne)).Select
 
Set recherche5 = Selection.Find(What:="Saint GOBAIN", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
If recherche5 Is Nothing Then
 
Set recherche6 = Selection.Find(What:="MCO", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
If recherche6 Is Nothing Then
 
Set recherche7 = Selection.Find(What:="DIESEL", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
If recherche7 Is Nothing Then
 
Set recherche8 = Selection.Find(What:="ESSENCE", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
 
 
If recherche8 Is Nothing Then
MsgBox "Aucun modele (Essence, diesel, Saint gobain et MCO) n'existe", vbCritical, "Erreur"
GoTo fin
 
Else
modele = "D:\Essais\COMMUN\Modele_ESSENCE.xls"
End If
 
Else
modele = "D:\Essais\COMMUN\Modele_DIESEL.xls"
End If
 
Else
modele = "D:\Essais\COMMUN\Modele_MCO.xls"
End If
 
Else
modele = "D:\Essais\COMMUN\Modele_saint_gobain.xls"
End If
 
 
If Dir(modele) = "" Then
MsgBox modele + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
ActiveWorkbook.Close
Workbooks.Open Filename:=modele
nommacro = ActiveWorkbook.Name
 
'recherche le repertoire le + récent
Racine = "D:\Banc0" + nompc + "_Donnees\donnees"
If Dir(Racine, vbDirectory) = "" Then
MsgBox Racine + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
 
ListeSousRepertoires Racine, True
recentDir = triDecroissant(Tableau2()) '
Erase Tableau2
h = 0
 
'Recherche le fichier T10 le plus récent
listeFichiers_dateModification recentDir
Workbooks.OpenText Filename:=triDecroissant2(Tableau2()), Origin:=xlMSDOS, _
        StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 4), Array(2, 1), Array(3, 1))
 
'Copie de la feuille de données brutes dans le fichier de dépouillement
Set Monclasseur = Application.ActiveWorkbook
nomclasseur = Monclasseur.Name
Selection.CurrentRegion.Select
Selection.Copy
Windows(nommacro).Activate
Sheets.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Windows(Monclasseur.Name).Activate
ActiveWorkbook.Close
 
'Copier coller des données brutes dans le tableaux de données traitées
 
Sheets("Données").Select
Range("A3").Select
    Do While ActiveCell.Value <> ""
    x = ActiveCell.Value
    Sheets("Feuil1").Select
    Range("A2").Select
          Do While ActiveCell.Value <> ""
            If ActiveCell.Value = x Then
            Selection.Offset(1, 0).Select
                If ActiveCell.Value <> "" Then
                Range(Selection, Selection.End(xlDown)).Copy
                Sheets("Données").Select
                Selection.Offset(3, 0).Select
                Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
                Application.CutCopyMode = False
                Selection.Offset(-3, 0).Select
                Sheets("Feuil1").Select
                End If
                Selection.Offset(-1, 0).Select
            End If
        Selection.Offset(0, 1).Select
        Loop
    Sheets("Données").Select
    Selection.Offset(0, 1).Select
 
    Loop
 
Sheets("Feuil1").Delete
Sheets("Données").Select
Range("A1").Select
 
'Chercher la coordonnée de ligne finale du tableau
 
finligne = Range("a6").End(xlDown).Address
finligne = Range(finligne).Row
 
'Chercher la coordonnée de colonne finale du tableau
 
fincolonne = Range("a3").End(xlToRight).Address
fincolonne = Range(fincolonne).Column
 
'Insertion des formules de calcul
 
'Calcul temps
Range("c6").Select
ActiveCell.Formula = "00:00:00"
Range("c7").Select
ActiveCell.Formula = "=c6+B7-B6"
Selection.AutoFill Destination:=Range("c7:c" + CStr(finligne))
 
'Mise en forme du tableau
Range(Cells(6, 1), Cells(finligne, fincolonne)).Select
 
      With Selection.Font
        .Name = "Arial Narrow"
        .Size = 10
      End With
 
      With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
      End With
 
   With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 
Range("A1").Select
 
'Ouverture du fichier txt pour import de la cause de l'arrêt
Dim nomfichierT00 As String
Dim fichiertxt As Variant
 
nomfichierT00 = Left(Mid(nomdossier, 5), 2) + Left(Mid(nomdossier, 3), 2) + Left(Mid(nomdossier, 7), 2) + Right(nomdossier, 2) + ".Txt"
 
fichiertxt = "D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier + "\" + nomfichierT00
 
If Dir(fichiertxt) = "" Then
MsgBox fichiertxt + " n'existe pas", vbCritical, "Erreur"
GoTo fin:
End If
 
Workbooks.OpenText Filename:=fichiertxt, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, _
4), Array(8, 1), Array(19, 1), Array(23, 1), Array(42, 1), Array(54, 1), Array(57, 1)), _
TrailingMinusNumbers:=True
Dim lignemini As String, lignearret As String, recherche1 As Variant, recherche2 As Variant
 
lignemini = Range("A1").End(xlDown).Row
Range(Cells(CStr(lignemini) - 5, 1), Cells(CStr(lignemini), 7)).Select
 
Set recherche1 = Selection.Find(What:="arret ", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
If recherche1 Is Nothing Then
 
Set recherche2 = Selection.Find(What:="méthode", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
 
If recherche2 Is Nothing Then
 
GoTo suite
 
Else
lignearret = Selection.Find(What:="méthode", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
End If
 
Else
lignearret = Selection.Find(What:="arret ", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Row
 
End If
 
Dim datearret As Date, heurearret As Date, causearret As String
 
datearret = Range("A" + CStr(lignearret)).Value
heurearret = Range("B" + CStr(lignearret)).Value
causearret = Range("G" + CStr(lignearret)).Value
 
suite:
 
ActiveWorkbook.Close
 
If causearret <> "" Then
Range("A1").Formula = causearret & Chr(10) & "Le " & datearret & " à " & heurearret
End If
 
'enregistrement automatique
 
Sheets("Données").Select
Range("A1").Select
ActiveWorkbook.SaveAs "D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier + "\" + Left(nomclasseur, 8) + ".xls"
ActiveWindow.Close
 
'ouvrir dossier
Dim objshell As Shell
Set objshell = New Shell
objshell.explore ("D:\Banc0" + nompc + "_Donnees\Donnees\" + nomdossier)
 
Application.Quit
GoTo fin:
 
error:
MsgBox "Problème d'execution du code : voir le créateur du code !!!", vbCritical
MsgBox Err.Description, vbCritical, "ERREUR"
 
fin:
 
End Sub
 
Sub ListeSousRepertoires(SourceFolderName As String, _
IncludeSubfolders As Boolean) ' adapté de Ole P Erlandsen
Dim Fso As Object, SourceFolder As Object, SubFolder As Object
Dim RepItem As Object
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(SourceFolderName)
 
    h = h + 1
    ReDim Preserve Tableau2(3, h)
    Tableau2(1, h) = SourceFolder
    Tableau2(2, h) = SourceFolder.DateLastModified
    Tableau2(3, h) = SourceFolder.Name
 
    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.subFolders
        ListeSousRepertoires SubFolder.Path, IncludeSubfolders
 
        Next SubFolder
    End If
 
End Sub
Sub listeFichiers_dateModification(chemin As String)
Dim Fichier As String
Dim Fso As Object, FileItem As Object
 
Fichier = Dir(chemin & "\*.*")
 
Do
    h = h + 1
    ReDim Preserve Tableau2(3, h)
 
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set FileItem = Fso.GetFile(chemin & "\" & Fichier)
 
    Tableau2(1, h) = FileItem
    Tableau2(2, h) = FileItem.DateLastModified 'lastmodified
    Tableau2(3, h) = FileItem.Type
 
    Fichier = Dir
Loop Until Fichier = ""
 
End Sub
Function triDecroissant(Tableau()) As String
Dim i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
 
 
Do
    Valeur = 0
    For i = 1 To h - 1
        If CDate(Tableau(2, i)) < CDate(Tableau(2, i + 1)) Then
            For z = 1 To 3
                Cible = Tableau(z, i)
                Tableau(z, i) = Tableau(z, i + 1)
                Tableau(z, i + 1) = Cible
 
            Next z
Valeur = 1
        End If
 
    Next i
 
Loop While Valeur = 1
 
 
'--- le plus récent ---
nomdossier = Tableau(3, 1)
triDecroissant = Tableau(1, 1)
End Function
 
Function triDecroissant2(Tableau()) As String
Dim i As Integer
Dim z As Byte, Valeur As Byte
Dim Cible As Variant
Dim g As Integer
Dim chemin As String
 
 
Do
    Valeur = 0
    For i = 1 To h - 1
        If CDate(Tableau(2, i)) > CDate(Tableau(2, i + 1)) Then
            For z = 1 To 3
                Cible = Tableau(z, i)
                Tableau(z, i) = Tableau(z, i + 1)
                Tableau(z, i + 1) = Cible
 
            Next z
 
        Valeur = 1
        End If
 
    Next i
 
Loop While Valeur = 1
 
 
'--- le plus récent de type T00 ---
 
For g = 1 To h
If Tableau(3, g) = "Fichier T00" Then
triDecroissant2 = Tableau(1, g)
Else
If Tableau(3, g) = "T00 File" Then
triDecroissant2 = Tableau(1, g)
End If
End If
 
Next g
 
If triDecroissant2 = "" Then
MsgBox "Aucun fichier de type T00 n'est present dans le dossier" + recentDir + "", vbCritical, "Erreur"
Exit Function
End If
 
 
End Function
Private Function ComputerName() As String
' Retourne le nom de l'ordinateur
Dim stTmp As String, lgTmp As Long
stTmp = Space$(250)
lgTmp = 251
Call GetComputerName(stTmp, lgTmp)
ComputerName = Split(stTmp, Chr$(0))(0)
End Function

30/06/2009, 20h13	#3
trblolo Invité de passage Inscription : janvier 2009 Messages : 16 Détails du profil Informations forums : Inscription : janvier 2009 Messages : 16 Points : 2 Points : 2	merci beaucoup sa fonctionne. Pourquoi est ce mieux un initialize ? Et a quoi sert le Doevents? Dernière modification par trblolo ; 30/06/2009 à 20h51.
	00

01/07/2009, 10h42	#4
trblolo Invité de passage Inscription : janvier 2009 Messages : 16 Détails du profil Informations forums : Inscription : janvier 2009 Messages : 16 Points : 2 Points : 2	Bonjour, Le programme précédent était un test pour connaître comment voir le gif s'animer. En réalité j'ai un programme assez long qui contient plusieurs boucle, plusieurs appel a des sous fonctions. J'ai essayé de mettre le DoeVENTS dans ce programme mais sa ne fonctionne pas. Faut-il mettre un doevents a chaque boucles, ou un seul? Y a t'il un endroit particulier pour mettre ce Doevents. Et a quoi sert réellement ce Doevents ? Merci pour votre aide ! Si il faut je mettrais mon code (il est assez long en fait).
	00

Outils de la discussion
Afficher une version imprimable Envoyer un lien vers cette page par email