I believe that I may have mistated the "everythings fine withe the Unzip routine" in my previous post. It is... but not the way you posted it. You need to end the function (not exit) and that red lettering was crazy. It seems like some useful code so I'm gonna blow off some web space and post the whole thing. Copy and paste and hopefully you will be zipping and unzipping away. Works for me. For fun create a "testfolder" folder on your "C" drive. Fill it full of all kinds of files. Use the code to Zip it to your "F" drive in this example. Delete the "testfolder" on the "C" drive. Then zip it back from the "F" drive to the "C" drive. You can actually call the zip and then the unzip in 2 lines of code. It didn't exist for a period of time on the "C" drive. Not sure if I like that? Getting rid of that creating then deleting folders would be good. It has something to do with creating an empty zip file on the new location and then passing the files to it rather being hammered headed with abit more code. Coding suggestions and comments always welcomed. Dave
ps. Thanks to Ron de Bruin for his great code.
To Zip...
'Testfolder (folder) must exist in "C" drive to start in this eg.
'(StartDrive As String, EndDrive As String, ZipThatFolder As String)
'to zip "Testfolder" from "C" to "F"
Call ZiptoNewDirectory("C", "F", "Testfolder")
To Unzip...
'(StartDrive As String, EndDrive As String, ZipThatFolder As String)
'To unzip "Testfolder" from "F" to "C"
Call UnZiptoNewDirectory("F", "C", "Testfolder")
End Sub
'Many thanks to Ron de Bruin for his great code
Public Function Zipp(ZipName, FileToZip)
'Zips A File
'ZipName must be FULL Path\Filename.zip - name Zip File to Create OR ADD To
'FileToZip must be Full Path\Filename.xls - Name of file you want to zip
Dim FSO As Object
Dim oApp As Object
If Dir(ZipName) = "" Then
Open ZipName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(ZipName).CopyHere (FileToZip)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(ZipName).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Public Function Unzip(DefPath, Fname)
'Unzips A File
'Fname must be FULL Path\Filename.zip
'DefPath must be valid Path you want to Unzip file TO
'You just need to pass 2 strings.
'C:\FullPath\Filename.zip - the file to UNZIP
'C:\FullPath\ - folder to unzip to
Dim FSO As Object
Dim oApp As Object
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(DefPath).CopyHere oApp.Namespace(Fname).items
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
Set oApp = Nothing
Set FSO = Nothing
End Function
Public Function ZiptoNewDirectory(StartDrive As String, _
EndDrive As String, ZipThatFolder As String)
'zip folder/file to a new directory
'ZipThatFolder is name of folder/file to be zipped
'eg. Call ZiptoNewDirectory("C", "F", "Testfolder")
'eg. Call ZiptoNewDirectory("C", "F", "Test.doc")
Dim FsoObj As Object, Temp2 As Object
Dim Drv As String, Foldername As String, EDrv As String
Drv = StartDrive & ":\" 'starting drive location
EDrv = EndDrive & ":\" 'ending drive location
Foldername = Drv & ZipThatFolder 'folder to be zipped
On Error Resume Next
'check for temp folder on same drive. Delete then create if it exists
Set FsoObj = CreateObject("Scripting.FileSystemObject")
Set Temp2 = FsoObj.getfolder(Drv & "temp")
If Temp2 <> "" Then
FsoObj.deletefolder (Drv & "temp"), False
End If
FsoObj.createfolder (Drv & "temp")
'zip folder into temp folder (*same drive location)
Call Zipp(Drv & "temp" & "\" & ZipThatFolder & ".zip", Foldername & "\")
'copy zipped folder to new drive (source,destination,save)
FsoObj.CopyFile Drv & "temp" & "\" & ZipThatFolder & ".zip", _
EDrv & ZipThatFolder & ".zip", True
FsoObj.deletefolder (Drv & "temp") 'delete temp folder
Set Temp2 = Nothing
Set FsoObj = Nothing
End Function
Public Function UnZiptoNewDirectory(StartDrive As String, _
EndDrive As String, UnZipThatFolder As String)
'unzip folder/file to new directory
' UnZipThatFolder is zipped file name
'eg. Call UnZiptoNewDirectory("F", "C", "Testfolder")
'eg. Call UnZiptoNewDirectory("F", "C", "Test.doc")
Dim Ofsobj As Object, Temp2 As Object
Dim Drv As String, Foldername As String, EDrv As Variant
Drv = StartDrive & ":\" 'starting drive location
EDrv = EndDrive & ":\" 'ending drive location
Foldername = EDrv & UnZipThatFolder 'unzipped folder name
'if unzipped folder already exists then delete
On Error Resume Next
Set Ofsobj = CreateObject("Scripting.FileSystemObject")
Set Temp2 = Ofsobj.getfolder(Foldername)
If Temp2 <> "" Then
Ofsobj.deletefolder (Foldername), False
End If
'unzip file to new directory
Call Unzip(EDrv, Drv & UnZipThatFolder & ".zip")
Set Temp2 = Nothing
Set Ofsobj = Nothing
End Function
Reply With Quote
Originally Posted by Dave
