[VB6] modShellZipUnzip.bas

[Bonnie West]

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.

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

[Bonnie West]

Updated the code - it now tries to cleanup the mess Shell left behind.

[couttsj]

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

[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.

[sergeos]

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?

[Bonnie West]

is there a way to still hide progress?

FindWindow + ShowWindow might be able to do it.

[sergeos]

FindWindow + ShowWindow might be able to do it.

can you help write the example?

[Bonnie West]

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!

[sergeos]

Thanks, but I'm weak in this matter

[Tomasek-TMK]

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

[Bonnie West]

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.

[Calcu]

HI all, i know it's and old code/post but i have a little question.

Due this process is Asynchronous, how can i wait until shellzip finishes to work

I tried

Do While ShellZip(Carpeta_Backup1 & Carpeta_Backup2 & "\" & sFolder, xFicheroDestino) = False

do something

loop

but if i'm zipping a big txt file, shellzip is true before it finishes to process the file

[Calcu]

I think i solved it, i have to do some checks but... it seems it works:

changed shellzip function to:

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&)
        
         ' Esperar a que termine el proceso de compresión
        Do While Not WaitForZipCompletion(DestZip)
            ShellZip = False
        Loop
    
        Pausa 2
    
        ShellZip = True
        
    On Error GoTo 0

End Function

Created a new function:

Private Function WaitForZipCompletion(ByRef DestZip As String) As Boolean
    Dim objShell As Object
    Dim objZip As Object
    Dim startTime As Single

    Set objShell = CreateObject("Shell.Application")
    Set objZip = objShell.NameSpace(CVar(DestZip))

    ' Tiempo máximo de espera en segundos
    Const TIMEOUT_SECONDS As Single = 60
    startTime = Timer

    Do
        ' Verifica si el ZIP contiene archivos (Items > 0)
        If objZip.Items.count > 0 Then
            WaitForZipCompletion = True
            Exit Function
        End If

        ' Salir si se supera el tiempo límite
        If Timer - startTime > TIMEOUT_SECONDS Then Exit Do
        DoEvents  ' Permitir que el sistema procese otros eventos
    Loop

    WaitForZipCompletion = False
End Function

[xiaoyao]

how to unzaip a file from abc.zip (have 20 files and folder),
unzip abc.zip\123\test.txt
unzip abc.zip\123 to D:\123

HOW TO ADD files or folders to abc.zip
addzipfiles d:\123b\ ,"abc.zip\123b"

[HackerVlad]

how to unzaip a file from abc.zip (have 20 files and folder),
unzip abc.zip\123\test.txt
unzip abc.zip\123 to D:\123

HOW TO ADD files or folders to abc.zip
addzipfiles d:\123b\ ,"abc.zip\123b"

Personally, for these purposes, I would use a class for working with ZIP from wqweto

[xiaoyao]

I've tested it. It's not difficult.

I never thought that this zip file could be edited. You can add files and delete files inside.Microsoft has managed this, ah, a zip file like a folder, which is really very clever.
If the ISO file can also directly add files, delete files, do not need to generate a new file, almost little modification ah, hard disk data so very good.

[BenJones]

Nice code if you don't mine I use this to use in my little VB projects backup tool. Thanks for shareing

[ezflyr]

Hi All,

I need to be able to create a .zip file containing a collection of files and folders. I found this thread, and thought it would be a good start as it seems simple enough. I used the code in post #1, and created a small test project. At the moment, I'm trying to simply zip a file in my project directory by doing this:

Public Sub Main()

Dim bSuccess As Boolean
bSuccess = ShellZip("Test.txt", "Test.zip")
If bSuccess = True Then MsgBox "OK" Else MsgBox "Fail"

End Sub

Although bSuccess = False, a .zip file, "Test.zip" is created, but it's empty. I was expecting it to contain the file "Test.txt".

What am I missing?

John

[wqweto]

> What am I missing?

Use full filenames incl. path to file.