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