Native Windows Zip

Forums

My Profile

Inbox

Address Book

My Subscription

My Forums

Native Windows Zip

Logged in as: Guest

arrSession:exec spGetSession 2,16,46632

	Active Users: There are 0 members and 0 guests.
	Users viewing this topic: none

Printable Version

All Forums >> [Scripting] >> Post a VBScript >> Native Windows Zip
Do you like VisualBasicScript.com? Link to us and help spread the word about our forum. Thanks!

Page: [1]

Message

<< Older Topic Newer Topic >>

Native Windows Zip - 5/4/2007 2:33:21 AM

DiGiTAL.SkReAM

Posts: 1194
Score: 7
Joined: 9/6/2005
From: Florida, USA
Status: offline

I've been looking for some code for a while now that would allow me to create ZIP files using the native windows compression (compressed folders, etc.). Well I found a function on Rob Van Der Woude's page that does this. I am posting it here after some slight modifications. For the original, go to http://www.robvanderwoude.com/vbstech_files_zip.html.

Function fZip(sSourceFolder,sTargetZIPFile)
'This function will add all of the files in a source folder to a ZIP file
'using Windows' native folder ZIP capability.
Dim oShellApp, oFSO, iErr, sErrSource, sErrDescription
Set oShellApp = CreateObject("Shell.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
 'The source folder needs to have a \ on the End
 If Right(sSourceFolder,1) <> "\" Then sSourceFolder = sSourceFolder & "\"
On Error Resume Next 
  'If a target ZIP exists already, delete it
  If oFSO.FileExists(sTargetZIPFile) Then oFSO.DeleteFile sTargetZIPFile,True 
 iErr = Err.Number
 sErrSource = Err.Source
 sErrDescription = Err.Description
On Error GoTo 0
 If iErr <> 0 Then   
  fZip = Array(iErr,sErrSource,sErrDescription)
  Exit Function
 End If
On Error Resume Next
 'Write the fileheader for a blank zipfile.
 oFSO.OpenTextFile(sTargetZIPFile, 2, True).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
 iErr = Err.Number
 sErrSource = Err.Source
 sErrDescription = Err.Description
On Error GoTo 0
 If iErr <> 0 Then   
  fZip = Array(iErr,sErrSource,sErrDescription)
  Exit Function
 End If
On Error Resume Next 
 'Start copying files into the zip from the source folder.
 oShellApp.NameSpace(sTargetZIPFile).CopyHere oShellApp.NameSpace(sSourceFolder).Items
 iErr = Err.Number
 sErrSource = Err.Source
 sErrDescription = Err.Description
On Error GoTo 0
 If iErr <> 0 Then   
  fZip = Array(iErr,sErrSource,sErrDescription)
  Exit Function
 End If
  'Because the copying occurs in a separate process, the script will just continue.  Run a DO...LOOP to prevent the function
  'from exiting until the file is finished zipping.
  Do Until oShellApp.NameSpace(sTargetZIPFile).Items.Count = oShellApp.NameSpace(sSourceFolder).Items.Count
   WScript.Sleep 500
  Loop
fZip = Array(0,"","")
End Function

_____________________________

"Would you like to touch my monkey?" - Dieter (Mike Meyers)

"It is better to die like a tiger, than to live like a pussy."
-Master Wong, from Balls of Fury

Post #: 1

RE: Native Windows Zip - 5/4/2007 6:08:26 AM

dm_4ever

Posts: 2724
Score: 46
Joined: 6/29/2006
From: Orange County, California
Status: offline

Very neat!

I have one that uses Shell.Application too, but this is better since you can specify the zip file name.

_____________________________

dm_4ever

My philosophy: K.I.S.S - Keep It Simple Stupid
Read Me: http://www.visualbasicscript.com/m_24727/tm.htm
Frequently Asked Stuff: http://www.visualbasicscript.com/m_47117/tm.htm

(in reply to DiGiTAL.SkReAM)