Re: VBA to zip excel spreadsheet using xp's compression system

[johndouglas]

i see that ron's solved the vba zipping with window xp program now

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

Zip file or files with the default Windows XP zip program (VBA)
Ron de Bruin (last update 23 Sept 2005)
Go to the Excel tips page

Many thanks to Tim Williams for pointed me to a thread in a Scripting
newsgroup.

I have used code from that thread to create this webpage.


Click here if you want to see a Unzip example

If you are a WinZip user then look also at this two pages.
http://www.rondebruin.nl/zip.htm
http://www.rondebruin.nl/unzip.htm


There are three macro's below :

1) You can browse to the folder you want and select the file or files
2) You can browse to a folder and zip all files in it
3) This macro zip all files in the folder that you enter in the code

Note: The macro's use also the macro and maybe the functions on the
bottom of this page


Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long
Dim FName, vArr, FileNameZip

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files
(*.xls), *.xls", _
MultiSelect:=True)

If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")

For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close: " & FName(iCtr)
Else
'Copy the file to the compressed folder
oApp.NameSpace(FileNameZip).CopyHere (FName(iCtr))
End If
Next iCtr

MsgBox "You find the zipfile here: " & FileNameZip
Set oApp = Nothing
End If
End Sub



Sub Zip_All_Files_in_Folder_Browse()
Dim FileNameZip, FolderName, oFolder
Dim strDate As String, DefPath As String
Dim oApp As Object

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")

'Browse to the folder
Set oFolder = oApp.BrowseForFolder(0, "Select folder to Zip", 512)
If Not oFolder Is Nothing Then
FolderName = oFolder.Self.Path
If Right(FolderName, 1) <> "\" Then
FolderName = FolderName & "\"
End If
'Copy the files to the compressed folder
oApp.NameSpace(FileNameZip).CopyHere
oApp.NameSpace(FolderName).items

MsgBox "You find the zipfile here: " & FileNameZip

Set oApp = Nothing
Set oFolder = Nothing
End If
End Sub



Note: Before you run the macro below change the folder in this macro
line
FolderName = "C:\Data\" '<< Change

Sub Zip_All_Files_in_Folder()
Dim FileNameZip, FolderName
Dim strDate As String, DefPath As String
Dim oApp As Object

DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If

FolderName = "C:\Data\" '<< Change

strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

'Create empty Zip File
NewZip (FileNameZip)

Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.NameSpace(FileNameZip).CopyHere
oApp.NameSpace(FolderName).items

MsgBox "You find the zipfile here: " & FileNameZip

Set oApp = Nothing
End Sub



Code that the macro's above use


Sub NewZip(sPath)
'Create empty Zip File
Dim oFSO, arrHex, sBin, i, Zip
Set oFSO = CreateObject("Scripting.FileSystemObject")
arrHex = Array(80, 75, 5, 6, 0, 0, 0, _
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
For i = 0 To UBound(arrHex)
sBin = sBin & Chr(arrHex(i))
Next
With oFSO.CreateTextFile(sPath, True)
.Write sBin
.Close
End With
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

 

[Ron de Bruin]

Yes, Sorry I forgot this thread.
Glad you found it.

I hope it is useful