VBA Access. Módulo de clase clsZip. Comprimir y descomprimir ficheros o carpetas: Zip, Unzip.

Option Compare Database
Option Explicit

'Zip / UnZip file or folder
'http://www.codekabinett.com/rdumps.php?Lang=2&targetDoc=create-zip-archive-vba-shell32

Public Function Zip(ByVal zipArchivePath As String, ByVal addPath As String) As String
On Error GoTo error
    Dim sh As Object
    Dim fSource As Object
    Dim fTarget As Object
    Dim iSource As Object
    Dim sourceItem As Object
    Dim i As Long
 
    Set sh = CreateObject("Shell.Application")

    Set fTarget = sh.NameSpace((zipArchivePath))
    If fTarget Is Nothing Then
        createZipFile zipArchivePath
        Set fTarget = sh.NameSpace((zipArchivePath))
    End If
 
    Dim containingFolder As String
    Dim itemToZip As String
    containingFolder = Left(addPath, InStrRev(addPath, "\"))
    itemToZip = Mid(addPath, InStrRev(addPath, "\") + 1)

    Set fSource = sh.NameSpace((containingFolder))
    For i = 0 To fSource.Items.Count - 1
        If fSource.Items.Item((i)).Name = itemToZip Then
            Set sourceItem = fSource.Items.Item((i))
            Exit For
        End If
    Next i
 
    fTarget.CopyHere sourceItem
 
    Zip = ""
     
Exit Function
error:
    Zip = Err.Number & ": " & Err.Description
    Debug.Print Err.Number & ": " & Err.Description, , "Zip"
End Function

Public Function UnZip(ByVal zipArchivePath As String, ByVal extractToFolder As String) As String
On Error GoTo error
    Dim sh As Object
    Dim fSource As Object
    Dim fTarget As Object
 
    Set sh = CreateObject("Shell.Application")

    Set fSource = sh.NameSpace((zipArchivePath))
    Set fTarget = sh.NameSpace((extractToFolder))
 
    fTarget.CopyHere fSource.Items
 
    UnZip = ""
 
Exit Function
error:
    UnZip = Err.Number & ": " & Err.Description
    Debug.Print Err.Number & ": " & Err.Description, , "UnZip"
End Function

Public Sub DeleteFileWithInvokeVerb(ByVal zipArchivePath As String, ByVal deleteFileName As String)
On Error GoTo error
    Dim sh As Object
    Dim fTarget As Object
    Dim iSource As Object
    Dim targetItem As Object
    Dim i As Long
 
    Set sh = CreateObject("Shell.Application")
    Set fTarget = sh.NameSpace((zipArchivePath))
 
    For i = 0 To fTarget.Items.Count - 1
        If fTarget.Items.Item((i)).Name = deleteFileName Then
            Set targetItem = fTarget.Items.Item((i))
            Exit For
        End If
    Next i

    If Not targetItem Is Nothing Then
        targetItem.InvokeVerb "Delete"
    End If

Exit Sub
error:
    MsgBox Err.Number & ": " & Err.Description
End Sub

Private Function createZipFile(ByVal fileName As String) As Boolean
On Error GoTo error
    Dim fileNo As Integer
    Dim ZIPFileEOCD(22) As Byte
 
    'Signature of the EOCD:  &H06054b50
    ZIPFileEOCD(0) = Val("&H50")
    ZIPFileEOCD(1) = Val("&H4b")
    ZIPFileEOCD(2) = Val("&H05")
    ZIPFileEOCD(3) = Val("&H06")
 
    fileNo = FreeFile
    Open fileName For Binary Access Write As #fileNo
    Put #fileNo, , ZIPFileEOCD
    Close #fileNo
 
    createZipFile = True
 
Exit Function
error:
    createZipFile = False
    Debug.Print Err.Number & ": " & Err.Description
End Function