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 |
Partager