VBA - how to unzip or zip files

Sometimes people ask me whether it is possible to work with zip archives directly in Excel application. That's why I decided to put here subroutines that can unpack a zip archive, pack up files to a zip archive or replace (actualize) an existing file in an existing zip archive.

There is used the Folder object and the Shell.NameSpace method to create this object.

UNZIP

Arguments:
sZipFile - path to a zip archive.
sFileName - only this file will be extracted from the sZipFile. If it isn't defined all files will be extracted.

Select all

Sub subUnzip(sZipFile As String, Optional sFileName As String = vbNullString)
  Const csDEST As String = "UNPACKED"

  If Not Len(Dir(sZipFile)) = 0 Then
    If Right$(sZipFile, 4) = ".zip" Then
      Dim sOutputDir As String
      sOutputDir = CreateObject("Scripting.FilesystemObject").GetParentFolderName(sZipFile) & "\" & csDEST
      
      With CreateObject("Shell.Application")
      MkDir sOutputDir
      If Len(sFileName) = 0 Then
        .Namespace(CStr(sOutputDir)).CopyHere .Namespace(CStr(sZipFile)).Items
      Else
        .Namespace(CStr(sOutputDir)).CopyHere .Namespace(CStr(sZipFile)).Items.Item(CStr(sFileName))
      End If
      End With 'CreateObject("Shell.Application")
    Else
      'your code if the file isn't a zip
    End If
  Else
    'your code if the zip-file doesn't exist
  End If
End Sub

ZIP

Arguments:
sPath - path to a file or directory to be packaged

Select all

Sub subZip(sPath As String)
  If Not Len(Dir(sPath, vbDirectory)) = 0 Then
    Dim sOutputFile As String
    sOutputFile = sPath & ".zip"
    
    If Len(Dir(sOutputFile)) = 0 Then
      Dim iFileNum As Integer
      iFileNum = FreeFile
      Open sOutputFile For Output As #iFileNum
      Print #iFileNum, "PK" & Chr(5) & Chr(6) & String(18, 0);
      Close #iFileNum
      
      With CreateObject("Shell.Application")
      If GetAttr(sPath) = vbDirectory Then
        .Namespace(CStr(sOutputFile)).CopyHere .Namespace(CStr(sPath)).Items
        While Not .Namespace(CStr(sPath)).Items.Count = .Namespace(CStr(sOutputFile)).Items.Count
        Wend
      Else
        .Namespace(CStr(sOutputFile)).CopyHere CStr(sPath)
      End If
      End With 'CreateObject("Shell.Application")
    Else
      'your code if the zipfile already exists
    End If
  Else
    'your code if the path doesn't exist
  End If
End Sub

REPLACE FILE

Arguments:
sZipFile - path to a zip archive.
sFileName - a file to be replaced.

Select all

Sub subReplaceInZip(sZipFile As String, sFileName As String)
  If Not Len(Dir(sZipFile)) = 0 Then
    If Right$(sZipFile, 4) = ".zip" Then
      If Not Len(Dir(sFileName)) = 0 Then
        With CreateObject("Shell.Application")
        Dim sFolder As String
        sFolder = CreateObject("Scripting.FilesystemObject").GetParentFolderName(sZipFile) & "\DeFaFrZi"
        MkDir sFolder

        Dim sInZip As String
        sInZip = Mid$(sFileName, InStrRev(sFileName, "\") + 1)
        
        .Namespace(CStr(sFolder)).MoveHere .Namespace(CStr(sZipFile)).Items.Item(CStr(sInZip))
        .Namespace(CStr(sZipFile)).CopyHere CStr(sFileName)
        End With 'CreateObject("Shell.Application")
        
        On Error Resume Next
        Kill sFolder & "\*.*"
        On Error GoTo 0
        RmDir sFolder
      Else
        'your code if the file doesn't exist
      End If
    Else
      'your code if the file isn't a zip
    End If
  Else
    'your code if the zip-file doesn't exist
  End If
End Sub

Tweet