Discussion :

[Coco47]

Bonjour à tous,

J'essai de copier des fichiers dans une archive zip. J'ai trouvé des bouts de code sur le net que j'ai assemblé et tout fonctionne bien sauf qu'à la fin mon archive est vide.
Avez vous une idée de ce qu'il pourrait ce passer ?

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
'Ensuite on va créer l'archive avec le nom CurrentFile
Dim FSO As Object
Dim f As Object
Dim nbFile As Integer
 
Set FSO = CreateObject("Scripting.FileSystemObject")
 
For Each Cell In wsData.Range("A2:A" & wsData.Range("A65535").End(xlUp).Row)
    For Each f In FSO.GetFolder(wsParam.Range("B1")).Files
      If f.Name Like "*" & Cell.Value & "*" Then
        If Len(Dir(CurrentFile)) = 0 Then
            Call NewZip(CurrentFile)
        End If
        Call CopierFichierDansArchiveExistant(f, CurrentFile)
      End If
    Next f
Next Cell
 
Sub CopierFichierDansArchiveExistant(ByVal FichierAArchiver As Variant, ByVal FichierZip As Variant)
 
'définition des variables
    Dim ApplicationArchivage As Object
 
'copier le fichier à archiver dans l'archive
    Set ApplicationArchivage = CreateObject("Shell.Application")
    ApplicationArchivage.Namespace(FichierZip).CopyHere FichierAArchiver
 
End Sub
 
Sub NewZip(ByVal sPath As String)
'Create empty Zip File
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

[fraflt69]

Bonjour Coco47, Pour moi le code NewScript que l'on voit partout ne fonctionne pas, Il vaut mieux interfacer 7Zip. Cdlt

[laurent_ott]

Bonjour, toutes les informations que vous cherchez sont dans cette discussion :
https://www.developpez.net/forums/d2...tes-d-outlook/

Cordialement.

[Coco47]

@fraflt69 : Ah bon ? Ok je vais essayé. Pourtant le fichier zip semble bien copié, j'ai l'impression que c'est la copie des fichiers a l'intérieur qui pose problème.

@laurent_ott : J'ai bien tout lu par contre c'est exactement les même procédure que ce que j'ai fais, sauf que chez moi ca ne marche pas.

[Coco47]

Alors pour répondre a la question en effet la création du .zip par le code NewScript semble poser problème.

Je suis passé par un appel de 7zip et ça fonctionne.

Voici mon code si ça peut aider.

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
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
 
 
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
    Dim hProg As Long
    Dim hProcess As Long, ExitCode As Long
    'fill in the missing parameter and execute the program
    If IsMissing(WindowState) Then WindowState = 1
    hProg = Shell(PathName, WindowState)
    'hProg is a "process ID under Win32. To get the process handle:
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
    Do
        'populate Exitcode variable
        GetExitCodeProcess hProcess, ExitCode
        DoEvents
    Loop While ExitCode = STILL_ACTIVE
End Sub
 
 
Function Add_File_To_Zip_File(ByVal NameZipFile As String, ByVal NameFileToZip As String)
    Dim PathZipProgram As String
    Dim ShellStr As String
 
    'Path of the Zip program
    PathZipProgram = "C:\program files\7-Zip\"
    If Right(PathZipProgram, 1) <> "\" Then
        PathZipProgram = PathZipProgram & "\"
    End If
 
    'Check if this is the path where 7z is installed.
    If Dir(PathZipProgram & "7z.exe") = "" Then
        MsgBox "Please find your copy of 7z.exe and try again"
        Exit Function
    End If
 
    'Zip the file
    ShellStr = PathZipProgram & "7z.exe u" _
             & " " & Chr(34) & NameZipFile & Chr(34) _
             & " " & Chr(34) & NameFileToZip & Chr(34)
 
    ShellAndWait ShellStr, vbHide
 
End Function