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
'     16 25-Aug-2026 Bernd Adapt to Logging v3
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 Logger   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 Logger = New clsLog
Logger.Name = "sbZip"
Logger.LogLevel = g_log_params.log_level
Logger.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
      Logger.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 Logger.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 Logger.warn "STDERR " & sLine
#End If
    Loop
    Do While oExec.Status = 0
      Application.Wait (Now + TimeValue("0:00:01"))
    Loop
#If SBZIP_LOG Then
    Logger.info vSourceFullPathName & "' zipped into '" & vDestinationZipFullPathName & "'"
#End If
  Else
#If SBZIP_LOG Then
    Logger.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
        Logger.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
Logger.info "Beendet ohne Fehler"
#End If
End Sub