Discussion :

[skysool]

Bonsoir

je cherche un moyen d'extraire un fichier ZIP
Quelqu'un a une idée ?

merci

[skysool]

Bonsoir,

j'ai fini par trouver :

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
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
 
Private ShellClass  As Shell32.Shell
Private Filesource  As Shell32.Folder
Private Filedest    As Shell32.Folder
Private Folderitems As Shell32.Folderitems
 
 
Public Sub ZipFile(File_Location As String, ZippedFile_Destination As String)
 
Create_New_Folder ZippedFile_Destination
 
If Right$(UCase$(ZippedFile_Destination), 4) <> ".ZIP" Then
   ZippedFile_Destination = ZippedFile_Destination & ".ZIP"
End If
 
If Not Create_Empty_Zip(ZippedFile_Destination) Then
   Set_To_Nothing
   Exit Sub
End If
 
 
Set ShellClass = New Shell32.Shell
Set Filedest = ShellClass.NameSpace(ZippedFile_Destination)
 
Call Filedest.CopyHere(File_Location, 20)
 
Call Sleep(1000)
 
End Sub
 
Public Sub ZipFolder(Folder_Location As String, ZippedFolder_Destination As String)
 
Create_New_Folder ZippedFolder_Destination
 
If Right$(UCase$(ZippedFolder_Destination), 4) <> ".ZIP" Then
   ZippedFolder_Destination = ZippedFolder_Destination & ".ZIP"
End If
 
If Not Create_Empty_Zip(ZippedFolder_Destination) Then
   Set_To_Nothing
   Exit Sub
End If
 
Set ShellClass = New Shell32.Shell
Set Filesource = ShellClass.NameSpace(Folder_Location)
Set Filedest = ShellClass.NameSpace(ZippedFolder_Destination)
Set Folderitems = Filesource.Items
 
Call Filedest.CopyHere(Folderitems, 20)
 
Call Sleep(1000)
 
End Sub
 
Public Sub Unzip(ZipFile_Location As String, UnzipFiles_Destination As String)
 
Create_New_Folder UnzipFiles_Destination
 
If Right$(UCase$(ZipFile_Location), 4) <> ".ZIP" Then
   ZipFile_Location = ZipFile_Location & ".ZIP"
End If
 
Set ShellClass = New Shell32.Shell
Set Filesource = ShellClass.NameSpace(ZipFile_Location)
Set Filedest = ShellClass.NameSpace(UnzipFiles_Destination)
Set Folderitems = Filesource.Items
 
Call Filedest.CopyHere(Folderitems, 20)
 
Call Sleep(1000)
 
End Sub
 
Private Function Create_Empty_Zip(sFileName As String, Optional sLocation As String) As Boolean
 
    Dim EmptyZip()  As Byte
    Dim J           As Integer
 
    On Error GoTo EH
    Create_Empty_Zip = False
 
    ReDim EmptyZip(1 To 22)
 
    EmptyZip(1) = 80
    EmptyZip(2) = 75
    EmptyZip(3) = 5
    EmptyZip(4) = 6
 
    For J = 5 To UBound(EmptyZip)
        EmptyZip(J) = 0
    Next
 
    If sLocation = "" Then
    Open sFileName For Binary Access Write As #1
    Else
    Open sFileName For Binary Access Write As #1
    End If
 
    For J = LBound(EmptyZip) To UBound(EmptyZip)
        Put #1, , EmptyZip(J)
    Next
 
    Close #1
 
    Create_Empty_Zip = True
 
EH:
 
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "Error"
    End If
 
End Function
 
Private Sub Set_To_Nothing()
    Set ShellClass = Nothing
    Set Filesource = Nothing
    Set Filedest = Nothing
    Set Folderitems = Nothing
End Sub
 
 
Private Function Create_New_Folder(str_FolderPath As String, Optional Ask_Privilege As Boolean, Optional MsgBox_OnOff As Boolean) As Boolean
Dim SplitFolders() As String
Dim Checking_CurrentFolder As String
Dim i As Integer
 
On Error GoTo ErrCreatingFolder
 
If Dir(str_FolderPath, vbDirectory) = vbNullString Then
   GoTo Split_Folders
 
Else
 
   Exit Function
 
End If
 
 
Split_Folders:
SplitFolders = Split(str_FolderPath, "\")
 
For i = 0 To UBound(SplitFolders)
   Checking_CurrentFolder = Checking_CurrentFolder & SplitFolders(i)
 
   If Dir(Checking_CurrentFolder, vbDirectory) = vbNullString Then
      MkDir (Checking_CurrentFolder)
   End If
 
   Checking_CurrentFolder = Checking_CurrentFolder & "\"
 
Next
 
If MsgBox_OnOff = True Then
   MsgBox "New folder " & Chr(34) & Left(Checking_CurrentFolder, Len(Checking_CurrentFolder) - 1) & " has been created!", vbExclamation, "New Folder Created"
End If
 
Create_New_Folder = True
 
Exit Function
 
ErrCreatingFolder:
Create_New_Folder = False
If MsgBox_OnOff = True Then
   MsgBox "Error Creating Folder"
End If
End Function
 
and to zip a file write
vb Code:
ZipFile 'Zip a single File
ZipFolder 'Zip a Folder
Unzip 'Unzip all Files from Zip File

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
ZipFile 'Zip a single File
ZipFolder 'Zip a Folder
Unzip 'Unzip all Files from Zip File

N'oubliez pas dans PROJECT et REFERENCES d'activer :
OLE AUTOMATION
Microsoft Shell controls and Automation