VBAでZIP圧縮する。

VBScriptからVBAに焼き直し。

Option Explicit

Sub MakeZIP(ZIPfile As String, ParamArray Files() As Variant)
Dim fso As Object
Dim Shell As Object
Dim zFolder As Object
Dim Path As Variant
Dim FileName As String
Dim sFolderItem As Object
Dim zFolderItem As Object
Dim Count As Long
Dim Ans As Long

Set fso = CreateObject("Scripting.FileSystemObject")
If UCase(fso.GetExtensionName(ZIPfile)) <> "ZIP" Then
  MsgBox "Invalid Extension Name - " & ZIPfile, vbCritical
  Exit Sub
End If
If Not fso.FileExists(ZIPfile) Then
  fso.CreateTextFile(ZIPfile, False).Write "PK" & Chr(5) & Chr(6) & String(18, 0)
End If
Set Shell = CreateObject("Shell.Application")
Set zFolder = Shell.Namespace(fso.GetAbsolutePathName(ZIPfile))
For Each Path In Files
  FileName = fso.GetFileName(Path)
  Set sFolderItem = Shell.NameSpace(fso.GetParentFolderName(fso.GetAbsolutePathName(Path))).ParseName(FileName)
  If sFolderItem Is Nothing Then
    MsgBox Path & " - Not Found.", vbCritical
    Exit For
  End If
  Do
    Set zFolderItem = zFolder.ParseName(FileName)
    If zFolderItem Is Nothing Then
      Count = zFolder.Items().Count
      zFolder.CopyHere sFolderItem
      Do While zFolder.Items().Count =< Count
        Application.Wait Now + TimeSerial(0, 0, 1)
      Loop
      Exit Do
    Else
      Ans = MsgBox("このフォルダには既に次のファイルが存在します:" & vbLf & vbLf & _
                 """" & FileName & """" & vbLf & vbLf & "既存のファイルと置き換えますか?", _
                 vbYesNoCancel + vbQuestion, "ファイル置換の確認")
      Select Case Ans
      Case vbYes
        zFolderItem.InvokeVerb ("delete")
      Case vbNo
        Exit Do
      Case vbCancel
        Exit For
      End Select
    End If
  Loop
Next
End Sub