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)