XL 2016 Fonction VBA créer un fichier zip pour X fichier CSV dans un dossier spécifique

[MR.O]

Bonjour,

Je souhaiterais savoir si vous pouviez m'indiquer comment faire une boucle pour zipper archiver, dans un autre dossier que le dossier source, 1 à X fichier CSV.

voici le code mais il plante pour faire la boucle pour le fichier suivant :

Sub CSV_ZIP_Click()

Dim RepCVS As String

Dim FichCSV As String

Dim RepZIP As String

Dim FichZIPName As Variant


RepCSV = "chemin du fichier CSV"

RepZIP = "chemin du fichier ou déposer le fichier zipper"

'----------------------------------------

FichCSV = Dir(RepCSV & "*.csv*")

Do While FichCSV <> ""

FichZIPName = RepZIP & Left(FichCSV, Len(FichCSV) - 4) & ".zip"

'créer un nouveau archive

If Len(Dir(FichZIPName)) > 0 Then Kill FichZIPName 'supprime l'archive s'il existe déjà

Open FichZIPName For Output As #1

Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)

Close #1

'copier le fichier à archiver dans l'archive

Set ApplicationArchivage = CreateObject("Shell.Application")

ApplicationArchivage.Namespace(FichZIPName).CopyHere FichCSV

FichCSV = Dir(RepCSV & "*.csv*")

Loop

End Sub

Merci d'avance pour votre aide,

Cordialement,

 

[kiki29]

Salut, de la lecture Compresser/décompresser des fichiers au format ZIP
sinon il y a ceci, minimaliste, à adapter à ton contexte.

Option Explicit

Sub ZipFichier()
Dim oShell As Object
Dim FSO As Object
Dim i As Long
Dim sFichier As String, sBin As String
Dim sZip As Variant, vHexa As Variant

    sFichier = ThisWorkbook.Path & "\" & "Essai.xls"
    sZip = ThisWorkbook.Path & "\" & "Essai.zip"

    Set FSO = CreateObject("Scripting.FileSystemObject")
    vHexa = 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(vHexa)
        sBin = sBin & Chr(vHexa(i))
    Next i

    With FSO.CreateTextFile(sZip, True)
        .Write sBin
        .Close
    End With

    Set oShell = CreateObject("Shell.Application")
    oShell.Namespace(sZip).CopyHere (sFichier)

    Set oShell = Nothing
    Set FSO = Nothing
End Sub

Sans oublier le site de Ron de Bruin

 

[MR.O]

Bonjour à tous,

C'est bon j'ai trouvé la solution pour ceux que cela intéresse je poste ci-dessous :

Sub CSV_ZIP_Click()
Dim ApplicationArchivage As Object
Dim RepCVS As String
Dim FichCSV As Variant
Dim RepZIP As String
Dim FichZIPName As Variant

RepCSV = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\CSV\"
RepZIP = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\ZIP\"
'----------------------------------------
FichCSV = Dir(RepCSV & "*.csv")

Do While FichCSV <> ""


FichZIPName = RepZIP & Left(FichCSV, Len(FichCSV) - 4) & ".zip"

'créer un nouveau archive
'If Len(Dir(FichZIPName)) > 0 Then Kill FichZIPName 'supprime l'archive s'il existe déjà
If FileExists(RepZIP & FichZIPName) Then
Kill FichZIPName 'supprime l'archive s'il existe déjà
End If
Open FichZIPName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copier le fichier à archiver dans l'archive
Set ApplicationArchivage = CreateObject("Shell.Application")
ApplicationArchivage.Namespace(FichZIPName).CopyHere RepCSV & FichCSV

FichCSV = Dir()

'boucle pour zipper par fichier
Loop

End Sub

Public Function FileExists(ByVal Pat As String) As Boolean
Dim Fso As Object '// Scripting.FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

FileExists = Fso.FileExists(Path)
End Function

 

[cp4]

Bonjour, C'est mieux ainsi. Démo à la suite pour utiliser le bon outil😛

Sub CSV_ZIP_Click()
Dim ApplicationArchivage As Object
Dim RepCVS As String
Dim FichCSV As Variant
Dim RepZIP As String
Dim FichZIPName As Variant

RepCSV = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\CSV\"
RepZIP = "C:\Users\Documents\TEST\DOSSIER A ZIPPER\ZIP\"
'----------------------------------------
FichCSV = Dir(RepCSV & "*.csv")

Do While FichCSV <> ""


FichZIPName = RepZIP & Left(FichCSV, Len(FichCSV) - 4) & ".zip"

'créer un nouveau archive
'If Len(Dir(FichZIPName)) > 0 Then Kill FichZIPName 'supprime l'archive s'il existe déjà
If FileExists(RepZIP & FichZIPName) Then
Kill FichZIPName 'supprime l'archive s'il existe déjà
End If
Open FichZIPName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copier le fichier à archiver dans l'archive
Set ApplicationArchivage = CreateObject("Shell.Application")
ApplicationArchivage.Namespace(FichZIPName).CopyHere RepCSV & FichCSV

FichCSV = Dir()

'boucle pour zipper par fichier
Loop

End Sub

Public Function FileExists(ByVal Pat As String) As Boolean
Dim Fso As Object '// Scripting.FileSystemObject
Set Fso = CreateObject("Scripting.FileSystemObject")

FileExists = Fso.FileExists(Path)
End Function

 

[patricktoulon]

Bonjour à tous
quelle vilaine manie que vous avez
vous êtes pas écolo du tout 🤣
perso je privilégie le recyclable
la création du zip doit être une fonction
le delete éventuel du fichier doit être optionnel ( histoire de pouvoir compiler dans une archive)