VBA zipファイルに圧縮する

■呼び出し元

'圧縮呼び出しテスト
Public Function testZip()
    '変数の宣言
    Dim ret As Boolean
    Dim filepath As Variant
 
    '圧縮対象フォルダ用配列
    Dim files(0)
    
    '配列に圧縮元フォルダのパスを格納する
    files(0) = "圧縮するフォルダのフルパスを入力"
    
    '圧縮ファイルのパスを指定する（拡張子まで含める）
    filepath = "作成するZIPファイルのフルパスを拡張子まで含めて入力"
     
    'ZIP圧縮を実行
    ret = makezip(filepath, files)
End Function

ファンクション

 Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As Long)
'ここから圧縮ルーチン
Public Function makezip(ByVal ZipPath, ByRef FileArray) As Boolean
'------------------------------------------------------------------
'機能：配列で受け取ったファイルを圧縮して指定したファイルパスで
'      zipファイルを生成する
'引数1：Zipファイルのパス
'引数2：圧縮対象のファイルパスを格納した配列
'------------------------------------------------------------------
    On Error GoTo Err_Handler
    '変数の宣言
    Dim FSO, sh, file, num, zipFolder
    
    '処理で使用するオブジェクトの初期化
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set sh = CreateObject("Shell.application")
    
    '古い同名圧縮ファイルがあったら削除する。
    If FSO.FileExists(ZipPath) = True Then
        FSO.DeleteFile ZipPath
    End If
    
    '空のzipファイルを生成
    With FSO.CreateTextFile(ZipPath, True)
        'Chr(5)は「ENQ」照会、Chr(6)は「ACK」肯定応答
        .Write "PK" & Chr(5) & Chr(6) & String(18, 0)
        .Close
    End With
    
    '新規作成したzipファイルへ圧縮対象をコピーする
    num = 0
    
    'zipファイルのパスを格納する
    Set zipFolder = sh.Namespace(FSO.GetAbsolutePathName(ZipPath))
    
    'ループで配列内のフォルダを圧縮フォルダに足していく
    For Each file In FileArray
        If CStr(file) <> "" Then
        file = FSO.GetAbsolutePathName(file)
        
        'Zipフォルダに圧縮対象のファイルをコピーする
        zipFolder.CopyHere (file)
        
        'ファイル数をカウントアップ
        num = num + 1
        End If
    Next
    
    'すべての圧縮ファイルのコピーが終わるまで待つ。
    Do Until zipFolder.Items().Count = num
        Sleep 100
    Loop
    
    '値を返す
    makezip = True
    
    '終了処理
    Set FSO = Nothing
    Set sh = Nothing
    
Exit_makezip:
    makezip = False
    Exit Function
    
Err_Handler:
    MsgBox Err.Description
    Resume Exit_makezip
 
End Function

ray88.hatenablog.com