VBA to zip excel spreadsheet using xp's compression system

Hi

I've been searching the web looking for a way to compress my
spreadsheets using VBA and the compression software that come as
default with xp.

I'd love to just install another program to zip my files with vba but
my work place will take a dim view of me downloading apps.

So, can anyone please provide me with the simple code i can cut and
paste. Or can the experts on the web and myself work on this till we
have a code we can all cut and paste.

I've seen various attampts across the web to do this ... but none seem
to work.

So, any experts with any ideas?

Thanks

JD

Hi John

I only have examples for Winzip
http://www.rondebruin.nl/zip.htm

I don't think it is possible with the Win XP zip program



--
Regards Ron de Bruin
http://www.rondebruin.nl


<johndouglas2005@yahoo.co.uk> wrote in message news:1126725936.934848.28970@o13g2000cwo.googlegroups.com...
> Hi
>
> I've been searching the web looking for a way to compress my
> spreadsheets using VBA and the compression software that come as
> default with xp.
>
> I'd love to just install another program to zip my files with vba but
> my work place will take a dim view of me downloading apps.
>
> So, can anyone please provide me with the simple code i can cut and
> paste. Or can the experts on the web and myself work on this till we
> have a code we can all cut and paste.
>
> I've seen various attampts across the web to do this ... but none seem
> to work.
>
> So, any experts with any ideas?
>
> Thanks
>
> JD
>

Hi John,

Ron de Bruin has great information on this at
http://www.rondebruin.nl/zip.htm.

Mike


"johndouglas2005@yahoo.co.uk" wrote:

> Hi
>
> I've been searching the web looking for a way to compress my
> spreadsheets using VBA and the compression software that come as
> default with xp.
>
> I'd love to just install another program to zip my files with vba but
> my work place will take a dim view of me downloading apps.
>
> So, can anyone please provide me with the simple code i can cut and
> paste. Or can the experts on the web and myself work on this till we
> have a code we can all cut and paste.
>
> I've seen various attampts across the web to do this ... but none seem
> to work.
>
> So, any experts with any ideas?
>
> Thanks
>
> JD
>
>

Thanks Mike

I add two examples this week to zip complete folders.
Maybe useful

--
Regards Ron de Bruin
http://www.rondebruin.nl


"MIKE215" <MIKE215@discussions.microsoft.com> wrote in message news:FFBC9097-C558-4B79-A0F2-D7E6399F2B47@microsoft.com...
> Hi John,
>
> Ron de Bruin has great information on this at
> http://www.rondebruin.nl/zip.htm.
>
> Mike
>
>
> "johndouglas2005@yahoo.co.uk" wrote:
>
>> Hi
>>
>> I've been searching the web looking for a way to compress my
>> spreadsheets using VBA and the compression software that come as
>> default with xp.
>>
>> I'd love to just install another program to zip my files with vba but
>> my work place will take a dim view of me downloading apps.
>>
>> So, can anyone please provide me with the simple code i can cut and
>> paste. Or can the experts on the web and myself work on this till we
>> have a code we can all cut and paste.
>>
>> I've seen various attampts across the web to do this ... but none seem
>> to work.
>>
>> So, any experts with any ideas?
>>
>> Thanks
>>
>> JD
>>
>>

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

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

I hope it is useful



--
Regards Ron de Bruin
http://www.rondebruin.nl


"johndouglas" <johndouglas2005@yahoo.co.uk> wrote in message news:1127496554.711923.54040@g47g2000cwa.googlegroups.com...
>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
>