Try this link
http://www.rondebruin.nl/zip.htm or here you are:
Zip Activeworkbook, File or Files with WinZip (VBA)
Ron de Bruin (last update 20 Juny 2004)
Go to the Excel tips page
Many thanks to Dave Peterson for his help to create this page.
The examples are only working If you use WinZip as your Zip program.
(Note: you must have a registered copy of WinZip)
Don't forget to copy the Functions in a normal module.
Check out also the Unzip web page if you need examples for unzip a zip file
Note : If you want to add a Password use this –sPassword then in the ShellStr.
Zip the ActiveWorkbook
Zip and Mail the ActiveWorkbook (with Outlook)
Choose one file with GetOpenFilename and zip it
Choose more files with GetOpenFilename and zip them
Functions
Zip the ActiveWorkbook
This example will zip the active workbook.
The zip file will be saved in the same folder.
Sub Zip_ActiveWorkbook()
Dim PathWinZip As String, FileNameZip As String, FileNameXls As String
Dim ShellStr As String, strDate As String
PathWinZip = "C:\program files\winzip\"
'This will check if this is the path where WinZip is installed.
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
' Build the date/Time string
strDate = Format(Now, "dd-mm-yy h-mm-ss")
' Build the path and name for the zip file
FileNameZip = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".zip"
' Build the path and name for the xls file
FileNameXls = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xls"
' Use SaveCopyAs to save the file with a Date/Time stamp
ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
'Zip the file
ShellStr = PathWinZip & "Winzip32 -min -a" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FileNameXls & Chr(34)
ShellAndWait ShellStr, vbHide
'Delete the file that you saved with SaveCopyAs
Kill FileNameXls
MsgBox "The macro is ready"
End Sub
Zip and mail the ActiveWorkbook
This will only work if you use Outlook as your mail program
Sub ActiveWorkbook_Zip_Mail()
'This sub will send a newly created workbook (copy of the Activeworkbook).
'It zip and save the workbook before mailing it with a date/time stamp.
'After the zip file is sent the zip file and the workbook will be deleted from your hard disk.
Dim PathWinZip As String, FileNameZip As String, FileNameXls As String
Dim ShellStr As String, strDate As String
Dim OutApp As Object
Dim OutMail As Object
PathWinZip = "C:\program files\winzip\"
'This will check if this is the path where WinZip is installed.
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
' Build the date/Time string
strDate = Format(Now, "dd-mm-yy h-mm-ss")
' Build the path and name for the zip file
FileNameZip = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".zip"
' Build the path and name for the xls file
FileNameXls = ActiveWorkbook.Path & "\" & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - 4) & " " & strDate & ".xls"
' Use SaveCopyAs to save the file with a Date/Time stamp
ActiveWorkbook.SaveCopyAs FileName:=FileNameXls
'Zip the file
ShellStr = PathWinZip & "Winzip32 -min -a" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FileNameXls & Chr(34)
ShellAndWait ShellStr, vbHide
'Send the File
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "ZipMailTest"
.Body = "Here is the File"
.Attachments.Add FileNameZip
.send
End With
Set OutMail = Nothing
Set OutApp = Nothing
'Delete the file that you saved with SaveCopyAs and the Zip file
Kill FileNameZip
Kill FileNameXls
End Sub
Choose one file with GetOpenFilename and zip it
This example use GetOpenFilename to select a file and zip it.
The zip file will be saved in the same folder.
Sub Zip_Selected_File()
Dim PathWinZip As String, FileNameZip As String, FileName As String
Dim ShellStr As String, strDate As String, sFileNameXls As String
Dim vArr As Variant, FileNameXls As Variant
PathWinZip = "C:\program files\winzip\"
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls")
If FileNameXls = False Then
'do nothing
Else
vArr = Split97(FileNameXls, "\")
sFileNameXls = vArr(UBound(vArr))
If bIsBookOpen(sFileNameXls) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close : " & FileNameXls
Exit Sub
End If
FileNameZip = Left(FileNameXls, Len(FileNameXls) - 4) & strDate & ".zip"
ShellStr = PathWinZip & "Winzip32 -min -a" _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & Chr(34) & FileNameXls & Chr(34)
ShellAndWait ShellStr, vbHide
MsgBox "The macro is ready"
End If
End Sub
Choose more files with GetOpenFilename and zip them
This example use GetOpenFilename to select a file or files and zip it.
The zip file will be saved in C:\.
Hold the CTRL key when You select the files you want.
Sub Zip_Selected_Files()
Dim PathWinZip As String, FileNameZip As String, NameList As String
Dim ShellStr As String, strDate As String, sFileNameXls As String
Dim vArr As Variant, FileNameXls As Variant, iCtr As Long
PathWinZip = "C:\program files\winzip\"
If Dir(PathWinZip & "winzip32.exe") = "" Then
MsgBox "Please find your copy of winzip32.exe and try again"
Exit Sub
End If
FileNameXls = Application.GetOpenFilename(filefilter:="Excel Files, *.xls", _
MultiSelect:=True)
If IsArray(FileNameXls) = False Then
'do nothing
Else
NameList = ""
For iCtr = LBound(FileNameXls) To UBound(FileNameXls)
NameList = NameList & " " & Chr(34) & FileNameXls(iCtr) & Chr(34)
vArr = Split97(FileNameXls(iCtr), "\")
sFileNameXls = vArr(UBound(vArr))
If bIsBookOpen(sFileNameXls) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close: " & FileNameXls(iCtr)
Exit Sub
End If
Next iCtr
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameZip = "C:\MyFilesZip " & strDate & ".zip "
ShellStr = PathWinZip & "Winzip32 -min -a " _
& " " & Chr(34) & FileNameZip & Chr(34) _
& " " & NameList
ShellAndWait ShellStr, vbHide
MsgBox "The macro is ready"
End If
End Sub
Functions
The examples use shell to run the winzip32.exe file.
You need the ShellAndWait function to wait until it the zip code is finished and run your other code.
The last two examples on this page use also the functions bIsBookOpen and Split97.
Where do I copy the code/functions?
1. Alt-F11
2. Insert>Module from the Menu bar
3. Paste the Code below
4. Alt-Q to go back to Excel
Copy this code below in the module
You can use a separate module for the macro examples.
'*************************************************************************************************
Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
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 bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
Split97 = Evaluate("{""" & _
Application.Substitute(sStr, sdelim, """,""") & """}")
End Function
'*****************************************************************************************