Automating Windows Built-in Zip Utility Application

[Dolphin Godfred]

Before I could start talking about this, I would like to sincerely thank Ron de Bruin, Vishesh for their efforts to create codes on native windows zip utility and use them. Seriously, without your support (through your website), I would not have created these codes.


What is Windows Built-in Zip Utility Application?

Starting Windows XP, Windows has basic built-in zip capability so that you can compress files by using the Compressed (zipped) Folder feature. Folders compressed by using this feature are identified by a zippered folder icon. Compressing files, folders, and programs decreases their size and reduces the space they use on your drives or removable storage devices.


In order to create or modify a zip file, you would use 2 objects, namely, the Shell object and FileSystemObject object. The Windows Shell namespace is an organized tree-structured hierarchical representation that Windows Explorer facilitates to graphically present file system contents and other objects to the end user. Conceptually, the Shell namespace may be regarded as a larger and more inclusive version of the file system. The FileSystemObject object is used to access the file system on a server or a local system. This object can manipulate files, folders, and directory paths. It is also possible to retrieve file system information with this object.


Ron’s code uses Application.GetOpenFilename to get the names of the file(s)/zip file.

http://www.rondebruin.nl/windowsxpunzip.htm

[code]http://www.rondebruin.nl/windowsxpzip.htm


Vishesh’s code explains to use a double quotes (") for each individual file path(s).

[code]http://excelexperts.com/Zip-Files-from-Excel

I just want to avoid using these and want the input for the user to be simple. The user simply enters the information in the cells and the code just picks them up and gives the end result. No selection of files or giving the path(s) in double quotes. Just type the source file(s) path(s)/files to extract with a comma (,) in between (not required at the end).


For example:

Files to zip:

C:TestFile1.txt,C:TestFile2.txt[/code]

Notice that there is no gap between the comma and the next file path.


Files to extract:

File1.txt,File2.txt[/code]

Notice that there is no gap between the comma and the next file.


Please add some additional codes for checking if the folder/file(s)/zip file (already) exists.


I know that the code can be tweaked some more for performance reason. So, please feel free to make changes. Also, let me know so that I can also keep a note of them.


Again, my sincere thanks to Ron and Vishesh.


Happy Coding!

Here go the codes:

Option Explicit

Sub Zip_Files()
'Create a zip file and add file(s) into it

Dim src_files As String
Dim dest_file As String
Dim src_file_path As String
Dim src_file_name As String

Dim arr_src_files() As String
Dim var_dest_file
Dim arr_files()

Dim lngCounter As Long, lngFileCounter As Long

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Dim oSA As Object

'Get source and destination files
src_files = Sheets("Sheet1&#34.Range("B1&#34.Value
dest_file = Sheets("Sheet1&#34.Range("B2&#34.Value

'Create FileSystemObject object
Set oFSO = CreateObject("Scripting.FileSystemObject&#34

'Add .zip at the end of destination file if .zip is not there
If Right(dest_file, 4) <> ".zip" Then dest_file = dest_file & ".zip"
var_dest_file = dest_file

'Put all the source files into an array
arr_src_files = Split(src_files, ",&#34

'Define the size of the array arr_files
ReDim arr_files(((UBound(arr_src_files) - LBound(arr_src_files)) + 1))

'Get all the files as objects
For lngCounter = LBound(arr_src_files) To UBound(arr_src_files)
src_file_path = Left(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "", , vbTextCompare))
src_file_name = Mid(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "&#34 + 1)

Set oFolder = oFSO.GetFolder(src_file_path)
For Each oFile In oFolder.Files
If InStr(oFile, src_file_name) Then
arr_files(lngCounter) = oFile
Exit For
End If
Next oFile

If lngCounter = UBound(arr_src_files) Then Exit For
Next lngCounter

'If the zip file already exists, delete the file
If Len(Dir(var_dest_file)) > 0 Then Kill var_dest_file

'Create an empty zip file
Open var_dest_file For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1

'Create Shell object
Set oSA = CreateObject("Shell.Application&#34

'Add files into the zip file
lngFileCounter = 0
For lngCounter = LBound(arr_files) To (UBound(arr_files) - 1)
'Copy file to zip folder/file created above
lngFileCounter = lngFileCounter + 1
oSA.Namespace(var_dest_file).CopyHere arr_files(lngCounter)

'Wait until compressing is complete
On Error Resume Next
Do Until oSA.Namespace(var_dest_file).Items.Count = lngFileCounter
Application.Wait (Now + TimeValue("0:00:01&#34)
Loop
On Error GoTo 0
Next lngCounter

Set oSA = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub

Sub Add_Files_To_Zip_File()
'Add file(s) into an existing zip file

Dim src_files As String
Dim dest_file As String
Dim src_file_path As String
Dim src_file_name As String

Dim arr_src_files() As String
Dim var_dest_file
Dim arr_files()

Dim lngCounter As Long, lngFileCounter As Long

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Dim oSA As Object

'Get source and destination files
src_files = Sheets("Sheet2&#34.Range("B1&#34.Value
dest_file = Sheets("Sheet2&#34.Range("B2&#34.Value

'Create FileSystemObject object
Set oFSO = CreateObject("Scripting.FileSystemObject&#34

'Add .zip at the end of destination file if .zip is not there
If Right(dest_file, 4) <> ".zip" Then dest_file = dest_file & ".zip"
var_dest_file = dest_file

'Put all the source files into an array
arr_src_files = Split(src_files, ",&#34

'Define the size of the array arr_files
ReDim arr_files(((UBound(arr_src_files) - LBound(arr_src_files)) + 1))

'Get all the files as objects
For lngCounter = LBound(arr_src_files) To UBound(arr_src_files)
src_file_path = Left(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "", , vbTextCompare))
src_file_name = Mid(arr_src_files(lngCounter), InStrRev(arr_src_files(lngCounter), "&#34 + 1)

Set oFolder = oFSO.GetFolder(src_file_path)
For Each oFile In oFolder.Files
If InStr(oFile, src_file_name) Then
arr_files(lngCounter) = oFile
Exit For
End If
Next oFile

If lngCounter = UBound(arr_src_files) Then Exit For
Next lngCounter

'Create a Shell object
Set oSA = CreateObject("Shell.Application&#34

'Add files into the zip file
lngFileCounter = 0
For lngCounter = LBound(arr_files) To (UBound(arr_files) - 1)
'Copy file to zip folder/file
oSA.Namespace(var_dest_file).CopyHere arr_files(lngCounter)

'Wait until compressing is complete
On Error Resume Next
lngFileCounter = (oSA.Namespace(var_dest_file).Items.Count + 1)
Do Until oSA.Namespace(var_dest_file).Items.Count = lngFileCounter
Application.Wait (Now + TimeValue("0:00:01&#34)
Loop
On Error GoTo 0
Next lngCounter

Set oSA = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub

Sub Unzip_All_Files()
'Extract all files from a zip file
Dim src_zip_file As String
Dim dest_folder As String
Dim src_file_path As String
Dim src_file_name As String

Dim arr_src_file() As String
Dim var_dest_folder
Dim arr_files()

Dim lngCounter As Long, lngFileCounter As Long

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Dim oSA As Object

'Get source zip file and destination folder
src_zip_file = Sheets("Sheet3&#34.Range("B1&#34.Value
dest_folder = Sheets("Sheet3&#34.Range("B2&#34.Value

'Create FileSystemObject object
Set oFSO = CreateObject("Scripting.FileSystemObject&#34

var_dest_folder = dest_folder

arr_src_file = Split(src_zip_file, ",&#34

'Define the size of the array arr_files
ReDim arr_files(((UBound(arr_src_file) - LBound(arr_src_file)) + 1))

'Get all the files as objects
For lngCounter = LBound(arr_src_file) To UBound(arr_src_file)
src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "", , vbTextCompare))
src_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "&#34 + 1)

Set oFolder = oFSO.GetFolder(src_file_path)
For Each oFile In oFolder.Files
If InStr(oFile, src_file_name) Then
arr_files(lngCounter) = oFile
Exit For
End If
Next oFile

If lngCounter = UBound(arr_src_file) Then Exit For
Next lngCounter

'Create a Shell object
Set oSA = CreateObject("Shell.Application&#34

'Extract all files into the destination folder
For lngCounter = LBound(arr_files) To (UBound(arr_files) - 1)
oSA.Namespace(var_dest_folder).CopyHere oSA.Namespace(arr_files(lngCounter)).Items
Next lngCounter

Set oSA = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub

Sub Unzip_One_File()
'Extract one file from a zip file
Dim src_zip_file As String
Dim dest_folder As String
Dim src_file_path As String
Dim src_zip_file_name As String
Dim src_file_name As String

Dim arr_src_file() As String
Dim var_dest_folder
Dim src_file
Dim file_name_in_zip
Dim arr_files()

Dim lngCounter As Long, lngCounter1 As Long, lngCounter2 As Long, lngFileCounter As Long

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Dim oSA As Object

'Get source zip file, file name to extract from the zip file, and destination folder
src_zip_file = Sheets("Sheet4&#34.Range("B1&#34.Value
src_file_name = Sheets("Sheet4&#34.Range("B2&#34.Value
dest_folder = Sheets("Sheet4&#34.Range("B3&#34.Value

'Create FileSystemObject object
Set oFSO = CreateObject("Scripting.FileSystemObject&#34

var_dest_folder = dest_folder

arr_src_file = Split(src_zip_file, ",&#34

'Define the size of the array arr_files
ReDim arr_files(((UBound(arr_src_file) - LBound(arr_src_file)) + 1))

'Get all the files as objects
For lngCounter = LBound(arr_src_file) To UBound(arr_src_file)
src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "", , vbTextCompare))
src_zip_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "&#34 + 1)

Set oFolder = oFSO.GetFolder(src_file_path)
For Each oFile In oFolder.Files
If InStr(oFile, src_zip_file_name) Then
arr_files(lngCounter) = oFile
Exit For
End If
Next oFile

If lngCounter = UBound(arr_src_file) Then Exit For
Next lngCounter

Set oFile = Nothing

'Create a Shell object
Set oSA = CreateObject("Shell.Application&#34

'Extract the file into the destination folder
For lngCounter1 = LBound(arr_files) To (UBound(arr_files) - 1)
For Each file_name_in_zip In oSA.Namespace(arr_files(lngCounter1)).Items
If LCase(Mid(file_name_in_zip.Path, InStrRev(file_name_in_zip.Path, "&#34 + 1)) Like LCase(src_file_name) Then
Set oFile = file_name_in_zip

If InStr(oFile.Path, src_file_name) Then
oSA.Namespace(var_dest_folder).CopyHere oSA.Namespace(arr_files(lngCounter1)).Items.Item(CStr(src_file_name))
Exit For
End If
End If
Next file_name_in_zip
Next lngCounter1

Set oSA = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub

Sub Unzip_Multiple_Files()
'Extract multiple files from a zip file
Dim src_zip_file As String
Dim dest_folder As String
Dim src_file_path As String
Dim src_zip_file_name As String
Dim src_file_names As String

Dim arr_src_file() As String
Dim arr_src_files() As String
Dim var_dest_folder
Dim src_file
Dim file_name_in_zip
Dim arr_files()

Dim lngCounter As Long, lngCounter1 As Long, lngCounter2 As Long, lngFileCounter As Long

Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object

Dim oSA As Object

'Get source zip file, file names to extract from the zip file, and destination folder
src_zip_file = Sheets("Sheet5&#34.Range("B1&#34.Value
src_file_names = Sheets("Sheet5&#34.Range("B2&#34.Value
dest_folder = Sheets("Sheet5&#34.Range("B3&#34.Value

'Create FileSystemObject object
Set oFSO = CreateObject("Scripting.FileSystemObject&#34

var_dest_folder = dest_folder

arr_src_file = Split(src_zip_file, ",&#34
arr_src_files = Split(src_file_names, ",&#34

'Define the size of the array arr_files
ReDim arr_files(((UBound(arr_src_file) - LBound(arr_src_file)) + 1))

'Get all the files as objects
For lngCounter = LBound(arr_src_file) To UBound(arr_src_file)
src_file_path = Left(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "", , vbTextCompare))
src_zip_file_name = Mid(arr_src_file(lngCounter), InStrRev(arr_src_file(lngCounter), "&#34 + 1)

Set oFolder = oFSO.GetFolder(src_file_path)
For Each oFile In oFolder.Files
If InStr(oFile, src_zip_file_name) Then
arr_files(lngCounter) = oFile
Exit For
End If
Next oFile

If lngCounter = UBound(arr_src_file) Then Exit For
Next lngCounter

Set oFile = Nothing

'Create a Shell object
Set oSA = CreateObject("Shell.Application&#34

'Extract the files into the destination folder
For lngCounter1 = LBound(arr_files) To (UBound(arr_files) - 1)
For Each file_name_in_zip In oSA.Namespace(arr_files(lngCounter1)).Items
For lngCounter2 = LBound(arr_src_files) To UBound(arr_src_files)
If LCase(Mid(file_name_in_zip.Path, InStrRev(file_name_in_zip.Path, "&#34 + 1)) Like _
LCase(arr_src_files(lngCounter2)) Then
Set oFile = file_name_in_zip

If InStr(oFile.Path, arr_src_files(lngCounter2)) Then
oSA.Namespace(var_dest_folder).CopyHere _
oSA.Namespace(arr_files(lngCounter1)).Items.Item(CStr(arr_src_files(lngCounter2)))
Exit For
End If
End If
Next lngCounter2
Next file_name_in_zip
Next lngCounter1

Set oSA = Nothing
Set oFile = Nothing
Set oFolder = Nothing
Set oFSO = Nothing
End Sub

 

[SirJB7]

Hi, Dolphin Godfred!


First of all welcome to Chandoo's website Excel forums. Thank you for your joining us and glad to have you here.


As a starting point I'd recommend you to read the three first green sticky topics at this forums main page. There you'll find general guidelines about how this site and community operates (introducing yourself, posting files, netiquette rules, and so on).


Among them you're prompted to perform searches within this site before posting, because maybe your question had been answered yet.


Feel free to play with different keywords so as to be led thru a wide variety of articles and posts, and if you don't find anything that solves your problem or guides you towards a solution, you'll always be welcome back here. Tell us what you've done, consider uploading a sample file as recommended, and somebody surely will read your post and help you.


And about your first post, well, thank you very much for sharing this with our community. Keep on going this way.


Regards!

 

[Dolphin Godfred]

SirJB7, Thank you.

Looking forward to add some more.


-DG