Option Explicit

Sub sbZip(ByVal vSourceFullPathName As Variant, _
  ByVal vDestinationZipFullPathName As Variant, _
  Optional bCreate As Boolean = True)
'Create zip file vDestinationZipFullPathName and insert zipped file or folder vSourceFullPathName.
'Version When         Who    What
'      1 24-Nov-2020  EotG   Original downloaded from https://exceloffthegrid.com/vba-cod-to-zip-unzip/
'      6 17-Dec-2020  Bernd  ByVal to enforce variants, single file feature and parameter bCreate added
'      7 25-Apr-2024  Bernd  lRepeat to avoid endless loops and parameter 16 for CopyHere to avoid
'                            confirmation prompt. No error checking.
'      8 12-Sep-2024  Bernd  Use a valid empty zip template if it exists.
'                            Workaround in case the print sequence fails.
Dim iFile             As Integer
Dim lItems            As Long
Dim lRepeat           As Long
Dim oShell            As Object
 
If bCreate Or Len(Dir(vDestinationZipFullPathName)) = 0 Then
  On Error Resume Next
  Kill vDestinationZipFullPathName
  On Error GoTo 0
  
  If Len(Dir(ThisWorkbook.Path & "\Zip_Template.zip")) = 0 Then
    iFile = FreeFile
    Open vDestinationZipFullPathName For Output As #iFile
    'This seems to cause issues in some cases:
    Print #iFile, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #iFile
  Else
    'Workaround is a valid empty zip file
    FileCopy ThisWorkbook.Path & "\Zip_Template.zip", vDestinationZipFullPathName
  End If
End If
 
On Error Resume Next
lItems = oShell.Namespace(vDestinationZipFullPathName).Items.Count
On Error GoTo 0
 
Set oShell = CreateObject("Shell.Application")
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
  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 Sub