Sub CreateZip()
   
  Dim iTmp As Integer, sTmp As String
  Dim oApp As Object
  Set oApp = CreateObject("Shell.Application")
     
  'Путь к зипу
   sTmp = "D:\MyArch.zip"
           
  'Получение числа файлов в архиве.
  'При ошибке будет создан пустой архив
  On Error GoTo ErrorLable
  iTmp = oApp.Namespace(sTmp & "").Items.Count
  On Error GoTo 0

  'Копируем файл в архив
  oApp.Namespace(sTmp & "").CopyHere "D:\MyFile.txt"
   
  'ждём завершения упаковки файла
  Do
    DoEvents: DoEvents
    Application.Wait (Now + TimeValue("0:00:01"))
  Loop Until oApp.Namespace(sTmp & "").Items.Count = iTmp + 1

  MsgBox "ОК"

Exit Sub

ErrorLable:
  If Err = 91 Then
    'При ошибке будет создан пустой архив
    Open sTmp For Binary Access Write As #1
    Put #1, 1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String$(18, 0)
    Close #1
    Resume
  End If

End Sub