-
Dec 14th, 2012, 05:06 PM
#1
[VB6] modShellZipUnzip.bas - Zip/Unzip Using Shell Library
The following code compresses/decompresses a file or folder to/from a zip file using the Microsoft Shell Controls And Automation library. It additionally tries to cleanup the mess Shell leaves behind when decompressing.
Code:
Option Explicit
'Asynchronously compresses a file or folder. Result differs if folder has a trailing backslash ("\").
Public Function ShellZip(ByRef Source As String, ByRef DestZip As String) As Boolean
CreateNewZip DestZip
On Error Resume Next
With CreateObject("Shell.Application") 'Late-bound
'With New Shell 'Referenced
If Right$(Source, 1&) = "\" Then
.NameSpace(CVar(DestZip)).CopyHere .NameSpace(CVar(Source)).Items
Else
.NameSpace(CVar(DestZip)).CopyHere CVar(Source)
End If
End With
ShellZip = (Err = 0&)
End Function
'Asynchronously decompresses the contents of SrcZip into the folder DestDir.
Public Function ShellUnzip(ByRef SrcZip As String, ByRef DestDir As String) As Boolean
On Error Resume Next
With CreateObject("Shell.Application") 'Late-bound
'With New Shell 'Referenced
.NameSpace(CVar(DestDir)).CopyHere .NameSpace(CVar(SrcZip)).Items
End With
ShellUnzip = (Err = 0&)
RemoveTempDir Right$(SrcZip, Len(SrcZip) - InStrRev(SrcZip, "\"))
End Function
'Creates a new empty Zip file only if it doesn't exist.
Private Function CreateNewZip(ByRef sFileName As String) As Boolean
With CreateObject("Scripting.FileSystemObject") 'Late-bound
'With New FileSystemObject 'Referenced
On Error GoTo 1
With .CreateTextFile(sFileName, Overwrite:=False)
.Write "PK" & Chr$(5&) & Chr$(6&) & String$(18&, vbNullChar)
.Close
1 End With
End With
CreateNewZip = (Err = 0&)
End Function
'Schedules a temporary directory tree for deletion upon reboot.
Private Function RemoveTempDir(ByRef sFolderName As String) As Boolean
Dim sPath As String, sTemp As String
On Error Resume Next
sTemp = Environ$("TEMP") & "\"
sPath = Dir(sTemp & "Temporary Directory * for " & sFolderName, vbDirectory Or vbHidden)
If LenB(sPath) Then
With CreateObject("WScript.Shell") 'Late-bound
'With New WshShell 'Referenced
Do: .RegWrite "HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce\*RD_" & _
Replace(sPath, " ", "_"), Environ$("ComSpec") & " /C " & _
"@TITLE Removing " & sPath & " ...&" & _
"@RD /S /Q """ & sTemp & sPath & """"
sPath = Dir
Loop While LenB(sPath)
End With
End If
RemoveTempDir = (Err = 0&)
End Function
Last edited by Bonnie West; Sep 1st, 2019 at 11:39 PM.
Reason: Changed HKLM to HKCU so that elevation won't be necessary.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
-
Dec 16th, 2012, 05:20 PM
#2
Code Update
Updated the code - it now tries to cleanup the mess Shell left behind.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
-
Jan 12th, 2013, 12:19 PM
#3
Re: [VB6] modShellZipUnzip.bas
The constant FOF_NOCONFIRMATION seems to have no impact at all. It still prompts me when I update an existing zip file. Is this normal?
J.A. Coutts
-
Jan 12th, 2013, 12:32 PM
#4
Re: [VB6] modShellZipUnzip.bas
Indeed, it has no effect at all. The Folder.CopyHere method notes that "in some cases, such as compressed (.zip) files, some option flags may be ignored by design". That flag may be left out.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
-
Mar 27th, 2013, 04:30 PM
#5
Addicted Member
Re: [VB6] modShellZipUnzip.bas
Originally Posted by Bonnie West
Indeed, it has no effect at all. The Folder.CopyHere method notes that "in some cases, such as compressed (.zip) files, some option flags may be ignored by design". That flag may be left out.
is there a way to still hide progress?
-
Mar 27th, 2013, 04:54 PM
#6
Re: [VB6] modShellZipUnzip.bas
Originally Posted by sergeos
is there a way to still hide progress?
FindWindow + ShowWindow might be able to do it.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
-
Mar 27th, 2013, 05:07 PM
#7
Addicted Member
Re: [VB6] modShellZipUnzip.bas
Originally Posted by Bonnie West
can you help write the example?
-
Mar 27th, 2013, 06:15 PM
#8
Re: [VB6] modShellZipUnzip.bas
There are plenty of examples of using both APIs here and elsewhere. If unsure about the parameters of either one, consult the given documentation link. They are pretty simple to use; I'm sure you will figure it out in no time!
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
-
Mar 27th, 2013, 06:19 PM
#9
Addicted Member
Re: [VB6] modShellZipUnzip.bas
Thanks, but I'm weak in this matter
-
Jun 11th, 2013, 08:31 AM
#10
Lively Member
Re: [VB6] modShellZipUnzip.bas
It is appropriate to use FOF_NOCONFIRMATION not bother Flask of the existence of the file.
module:
Public Const FOF_NOCONFIRMATION = & H10
Swap:
. Namespace (CVar (DestDir)). CopyHere. Namespace (CVar (SrcZip)). Items
The new code
. Namespace (CVar (DestDir)). CopyHere. Namespace (CVar (SrcZip)). Items, FOF_NOCONFIRMATION
-
Jun 11th, 2013, 09:49 AM
#11
Re: [VB6] modShellZipUnzip.bas
I've just tested that code again in Vista (it was originally developed in XP) and still, the Shell ignores the FOF_NOCONFIRMATION flag. So, whether you use that flag or not makes no difference.
On Local Error Resume Next: If Not Empty Is Nothing Then Do While Null: ReDim i(True To False) As Currency: Loop: Else Debug.Assert CCur(CLng(CInt(CBool(False Imp True Xor False Eqv True)))): Stop: On Local Error GoTo 0
Declare Sub CrashVB Lib "msvbvm60" (Optional DontPassMe As Any)
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|