openaccess/source/modules/OA_Zip.bas

Option Explicit
Option Base 0

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMiliseconds As Long)

Public Sub zipfile(zipPath As String, filePath As String)
  createzip zipPath
  addfile zipPath, filePath
End Sub

Public Sub zipfolder(zipPath As String, folderpath As String)
  Dim file As Variant
  createzip zipPath
  For Each file In CreateObject("Scripting.FileSystemObject").GetFolder(folderpath).Files
      addfile zipPath, CStr(file)
  Next file
End Sub

Private Sub addfile(zipPath As String, filePath As String)
  Dim sh As Shell32.Shell, fdr As Shell32.Folder, cntItems As Integer 'cnt = Count
  Set sh = CreateObject("Shell.Application")
  Set fdr = sh.NameSpace(zipPath)
  cntItems = fdr.Items.count
  fdr.CopyHere filePath, 4 + 16 + 1024
  Do
    Sleep 1000
  Loop Until cntItems < fdr.Items.count
  Set fdr = Nothing
  Set sh = Nothing
End Sub

Private Sub createzip(zipPath As String)
  Dim fso As Scripting.FileSystemObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(zipPath) Then
    fso.DeleteFile zipPath
  End If
  fso.CreateTextFile(zipPath).Write "PK" & Chr(5) & Chr(6) & String(18, Chr(0))
  Set fso = Nothing
End Sub