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
