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.
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
  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
 
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

Sub WaitForFileExists(sFullPathName As String)
'Wait up to 10s until sFullPathName exists.
'Version When         Who    What
'      1 25-Apr-2024  Bernd  Initial version without error checking.
Dim lTimer            As Long
Dim MyFSO             As FileSystemObject 'Necessary reference: Microsoft Scripting Runtime Library (Scrrun.dll)

Do
  DoEvents
  Application.Wait (Now + TimeValue("0:00:01"))
  If Timer > lTimer + 10 Then Exit Do
Loop Until MyFSO.FileExists(sFullPathName)

End Sub

Sub Test()

'VERY simple test. Keep in mind that the Excel file's name is Test.xlsm after testing.
ThisWorkbook.SaveAs ThisWorkbook.Path & "\Test.xlsm"
Call WaitForFileExists(ThisWorkbook.Path & "\Test.xlsm")
Call sbZip(ThisWorkbook.Path & "\Test.xlsm", ThisWorkbook.Path & "\Test.zip", True)

End Sub