On Tue, 20 Nov 2007 04:13:10 GMT, "Tony Toews [MVP]"
<tt****@teluspl anet.netwrote:
>Chuck Grimsby <c.*******@worl dnet.att.net.in validwrote:
>>Create, extract, or both?
If the target machine is XP SP2, then all the DLLs you need are
already installed.
(Although to be honest, I've only does this with a VBScript file, not
in VBA.)
>Interesting. Got any URLs with VBScript code?
I got the source for this somewhere in Usenet, although I've forgotten
where. I have the full message, but it's on a Backup disk somewhere.
(It's not exactly new!)
Some who *really* knows VBScript could probably do a better job, but
this works.
This creates a Zip file and copies the contents of a whole folder into
it. As always, watch out for word wrap....
---------------------- Cut Here ------------------------------------
Option Explicit
Dim ZipFileName, FolderToZip
Dim oApp, MyHex, MyBinary, i
Dim oFSO, oTF
MyHex = 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(MyHex)
MyBinary = MyBinary & Chr(MyHex(i))
Next
FolderToZip = "C:\Data Files\My Data\"
' in case someone forgets the last slash:
If Right(FolderToZ ip, 1) <"\" Then
FolderToZip = FolderToZip & "\"
End If
ZipFileName = "G:\Backups \" & _
FormatNowISO & _
"MyDataBackup.z ip"
'Create empty Zip File
Set oFSO = CreateObject("S cripting.FileSy stemObject")
Set oTF = oFSO.CreateText File(ZipFileNam e, True)
oTF.Write MyBinary
oTF.Close
Set oTF = Nothing
Set oFSO = Nothing
'Copy the files to the compressed folder
Set oApp = CreateObject("S hell.Applicatio n")
oApp.NameSpace( ZipFileName).Co pyHere _
oApp.NameSpace( FolderToZip).it ems
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.NameSpace( ZipFileName).it ems.Count =
oApp.NameSpace( FolderToZip).it ems.Count
Application.Wai t (Now + TimeValue("0:00 :01"))
Loop
Set oApp = Nothing
On Error GoTo 0
'MsgBox "Done!" & vbnewline & _
"You'll find the zipfile here: " & vbnewline & _
ZipFileName
WScript.Quit
Function FormatNowISO
FormatNowISO = DatePart("yyyy" , Now())
FormatNowISO = FormatNowISO & Right("00" & DatePart("m", Now()), 2)
FormatNowISO = FormatNowISO & Right("00" & DatePart("d", Now()), 2)
' if the time is needed:
'FormatNowISO = FormatNowISO & _
Right("00" & DatePart("h", Now()), 2)
'FormatNowISO = FormatNowISO & _
Right("00" & DatePart("n", Now()), 2)
'FormatNowISO = FormatNowISO & _
Right("00" & DatePart("s", Now()), 2)
End Function
---------------------- Cut Here ------------------------------------
I'll have to dig out the backup to get at a un-zip script. As I
remember, it's pretty much the same thing, just copying the files out
of the (zipped) folder. I'll see if I can dig it out over the
Thanksgiving holiday.
Please Post Any Replies To This Message Back To the Newsgroup.
There are "Lurkers" around who can benefit by our exchange!
