[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 :

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 :

.....
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 :

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" ( _
                 ByVal lpBuffer As String, _
                 nSize As Long) As Long
Sub auto_open()
 
UserForm1.Show
 
End Sub

Code :

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, 19h52	#1
trblolo Invité régulier Date d'inscription: janvier 2009 Messages: 14	problème webbrowser utilisation 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 : 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

30/06/2009, 20h13	#3
trblolo Invité régulier Date d'inscription: janvier 2009 Messages: 14	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.

30/06/2009, 20h05	#2
mapeh Membre actif Date d'inscription: octobre 2007 Localisation: 29 Messages: 176	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 : ..... i = i + 1 DoEvents Loop .... et supprime le Repaint...

01/07/2009, 10h42	#4
trblolo Invité régulier Date d'inscription: janvier 2009 Messages: 14	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).

		Forum des professionnels en informatique > Logiciels > Microsoft Office > Excel > Macros et VBA Excel
[XL-2003] problème webbrowser utilisation

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