sbZip (VBA)

Sun, 24 May 2026 08:04:00 +0100
Abstract

Mit VBA kann man leicht einen Ordner oder eine Datei im Zip-Format komprimieren.
Diese Variante ist meine bevorzugte:
Appendix – sbZip Code

Bitte den Haftungsausschluss im Impressum beachten.
Option Explicit

#Const SBZIP_LOG = True 'Use sbZip with logging (True) or not (False)

Sub sbZip(ByVal vSourceFullPathName As Variant, _
          ByVal vDestinationZipFullPathName As Variant, _
          Optional bCreate As Boolean = True, _
          Optional bUse7zip As Boolean = False)
'Create zip file vDestinationZipFullPathName and insert zipped file or folder vSourceFullPathName.
'This sub is using LibFileTools, https://github.com/cristianbuse/VBA-FileTools.
'If bUse7zip:=True then 7zip needs to be installed at C:\Program Files\7-Zip\7z.exe.
'Version When        Who   What
'     14 08-May-2025 Bernd Overwrite zip constituent (by moving it to Temp)
'                          without warning message that it already exists
'     15 25-Dec-2025 Bernd Use #If SBZIP_LOG
Dim iFile     As Integer
Dim lItems    As Long
Dim lRepeat   As Long
Dim sBasename As String
Dim sLine     As String
Dim sShellCmd As String
Dim sPath     As String
Dim v         As Variant
Dim oExec     As Object
Dim oOutput   As Object
Dim oShell    As Object
#If SBZIP_LOG Then
Dim GLogger   As clsLog
#End If
#If MEASURE_RUNTIME Then
Dim cPerf     As clsPerf 'See: https://jkp-ads.com/Articles/performanceclass.asp

Set cPerf = New clsPerf
cPerf.SetRoutine "sbZip"
#End If
#If SBZIP_LOG Then
Set GLogger = New clsLog
g_log_params.log_sub_name = "sbZip"
GLogger.info "Started with vSourceFullPathName = '" & vSourceFullPathName & _
          "', vDestinationZipFullPathName = '" & vDestinationZipFullPathName & _
          "', bCreate = " & bCreate & _
          "', bUse7zip = " & bUse7zip
#End If
If bCreate Then
  If IsFile(CStr(vDestinationZipFullPathName)) Then
    If Not DeleteFile(CStr(vDestinationZipFullPathName)) Then
#If SBZIP_LOG Then
      GLogger.warn "Could not delete file '" & vDestinationZipFullPathName & "'"
#End If
    End If
  End If
End If
If bUse7zip Then
  If IsFile("C:\Program Files\7-Zip\7z.exe") Then
    Set oShell = CreateObject("WScript.Shell")
    sShellCmd = "C:\Program Files\7-Zip\7z.exe a """ & vDestinationZipFullPathName & _
      """ """ & vSourceFullPathName & """"
    Set oExec = oShell.exec(sShellCmd)
    Set oOutput = oExec.StdOut
    Do While Not oOutput.AtEndOfStream
      sLine = oOutput.ReadLine
#If SBZIP_LOG Then
      If sLine <> "" Then GLogger.info "STDOUT " & sLine
#End If
    Loop
    Set oOutput = oExec.StdErr
    Do While Not oOutput.AtEndOfStream
      sLine = oOutput.ReadLine
#If SBZIP_LOG Then
      If sLine <> "" Then GLogger.warn "STDERR " & sLine
#End If
    Loop
    Do While oExec.Status = 0
      Application.Wait (Now + TimeValue("0:00:01"))
    Loop
#If SBZIP_LOG Then
    GLogger.info vSourceFullPathName & "' zipped into '" & vDestinationZipFullPathName & "'"
#End If
  Else
#If SBZIP_LOG Then
    GLogger.fatal "C:\Program Files\7-Zip\7z.exe doesn't exist. Cannot zip '" & _
    vSourceFullPathName & "'"
#End If
  End If
Else
  If bCreate Then
    sPath = GetLocalPath(ThisWorkbook.Path)
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    If IsFile(sPath & "Zip_Template.zip") Then
      'Workaround in case print sequence in Else clause does not work
      CopyFile sPath & "Zip_Template.zip", CStr(vDestinationZipFullPathName)
      If Not IsFile(CStr(vDestinationZipFullPathName)) Then
#If SBZIP_LOG Then
        GLogger.warn "Could not copy template file '" & vDestinationZipFullPathName & "'"
#End If
      End If
    Else
      iFile = FreeFile
      Open vDestinationZipFullPathName For Output As #iFile
      Print #iFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
      Close #iFile
    End If
  End If
 
  Set oShell = CreateObject("Shell.Application")
  On Error Resume Next
  lItems = oShell.Namespace(vDestinationZipFullPathName).Items.Count
  On Error GoTo 0
  If GetAttr(vSourceFullPathName) = vbDirectory Then
    oShell.Namespace(vDestinationZipFullPathName).CopyHere _
    oShell.Namespace(vSourceFullPathName).Items, 16
    lRepeat = 0
    On Error Resume Next
    Do Until oShell.Namespace(vDestinationZipFullPathName).Items.Count = _
      lItems + oShell.Namespace(vSourceFullPathName).Items.Count Or lRepeat > 5
      Application.Wait (Now + TimeValue("0:00:01"))
      lRepeat = lRepeat + 1
    Loop
    On Error GoTo 0
  Else
    If lItems > 0 Then
      sBasename = Right(vSourceFullPathName, InStr(StrReverse(vSourceFullPathName), "\") - 1)
      For Each v In oShell.Namespace(vDestinationZipFullPathName).Items
        If v.Name = sBasename Then
          oShell.Namespace(Environ("Temp")).MoveHere (v)
          DeleteFile Environ("Temp") & "\" & sBasename
          Exit For
        End If
      Next v
    End If
    oShell.Namespace(vDestinationZipFullPathName).CopyHere vSourceFullPathName, 16
    lRepeat = 0
    On Error Resume Next
    Do Until oShell.Namespace(vDestinationZipFullPathName).Items.Count = _
      lItems + 1 Or lRepeat > 3
      Application.Wait (Now + TimeValue("0:00:01"))
      lRepeat = lRepeat + 1
    Loop
    On Error GoTo 0
  End If
End If
#If SBZIP_LOG Then
GLogger.info "Beendet ohne Fehler"
#End If
End Sub
Download

Bitte den Haftungsausschluss im Impressum beachten.
Dateien Komprimieren on Bernd Plumhoff

sbZip (VBA)

Abstract

Appendix – sbZip Code

Download
