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 |
