Discussion :

[Johan_VBA]

Bonjour,

J'ai besoin de réaliser une petite macro qui zippe des fichiers en cascade mais je rencontre un petit soucis : dès que les fichiers prennent un peu de temps à zipper, j'ai des erreurs car Excel appelle "l'application externe" qui zippe pour un nouveau fichier alors qu'elle n'a pas fini de zipper le premier...

Si quelqu'un a une idée... Je n'ai rien trouvé sur le sujet en fouillant un peu partout sur le net, ou sinon c'était au-delà de ma compréhension..

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
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
Sub Zipp_Files(Nom_Dossier As String, Chemin As String)
 
'----------Commentaire--------------------------------------------------------------------------------------------------------------------
 
'Ce sub permet de zipper une serie de fichiers un par un se trouvant dans un dossier
 
'----------Déclaration des variables locales----------------------------------------------------------------------------------------------
 
Dim DossierZip As Variant
Dim DossierInit As Variant
Dim Fichier As Object
Dim Nom_Fichier As Variant
Dim oShell As Object
Dim FSO As Object
Dim oFSO As Object
Dim i As Long
Dim MyBinary As String
Dim MyHex As Variant
Dim Chemin_Fichier As Variant
 
'----------Initialisation des variables locales----------------------------------------------------------------------------------------------
 
DossierZip = Chemin & Nom_Dossier  & ".zip"
DossierInit = Chemin & Nom_Dossier 
 
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set FSO = CreateObject("Scripting.FileSystemObject")
 
'----------Code------------------------------------------------------------------------------------------------------------------------------
On Error GoTo err
 
MyHex = Array(80, 75, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
 
For i = 0 To UBound(MyHex)
    MyBinary = MyBinary & Chr(MyHex(i))
Next i
 
With FSO.CreateTextFile(DossierZip, True)
    .Write MyBinary
    .Close
End With
 
Set oShell = CreateObject("Shell.Application")
 
For Each Fichier In oFSO.GetFolder(DossierInit).Files
    Chemin_Fichier = Fichier.Path
    Fichier.Attributes = 0
    oShell.Namespace(DossierZip).CopyHere (Chemin_Fichier)
Next
 
err:
 
Select Case err.Number
    Case 58: MsgBox Contenu_MsgBox(1)  'Le fichier zip existe déjà
    Case 76: MsgBox Contenu_MsgBox(3)  'Chemin incorrect
    Case Else: MsgBox Contenu_MsgBox(4) & "Error n° " & err.Number 'Erreur inconnue
End Select
 
End Sub

[kiki29]

Salut, ce fichier ( à adapter bien sur pour les chemins ) fonctionne sans aucun problèmes.

[Johan_VBA]

Merci pour le fichier !

Je me rends compte que j'ai toujours le même problème, même en prenant ton code... Du coup je me dis que je suis peut être sur une fausse piste :/

Pourtant quand j’exécute le code ligne par ligne avec le débogueur, ça marche, mais quand je l’exécute normalement, ça plante.

J'ai mis un timer sur la boucle de création des zip, et ça m'a "résolu" le problème... Jusqu'au jour un quelqu'un voudra zipper des gros fichier, et là, ça risque de planter à nouveau mais bon. J'ai pas pu faire mieux pour l'instant !

[Johan_VBA]

A titre informatif, j'ai trouvé une solution à mon problème avec un wait et un test sur le nombre de fichiers présent dans le dossier zipper :

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
Set oShell = CreateObject("Shell.Application")
 
' Copie en une fois de tous les fichiers du dossier dans le zip
oShell.Namespace(DossierZip).CopyHere oShell.Namespace(DossierInit).items
 
' Fait patienter le script en attendant que la compression ait lieu:
'   si le nombre de fichiers contenu dans le Zip est différent du nombre de fichiers contenu dans le dossier
'     => on attends une seconde de plus et on re-vérifie.
On Error Resume Next
 
StartTime = Timer
 
Do Until oShell.Namespace(DossierZip).items.Count = oShell.Namespace(DossierInit).items.Count
    Application.Wait (Now + TimeValue("0:00:01"))
 
    'si le temps d'attente est suppérieur à 30 seconde, on arrete tout
    If Timer > StartTime + 30 Then
        goto Gestion_Erreur
    End If
Loop