ファイル/フォルダをzipファイルに圧縮

Scripting.FileSystemObject、Shell.Applicationを使っての実装。

実装内容は、空のzipファイルを作って、この空のzipファイルを書庫としてCopyHere関数を使って、圧縮対象のファイル/フォルダをコピーする。

#コード

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Function zip(pthary() As String, zippth As String) As Boolean
    zip = False
    On Error GoTo Err
    Dim sfo As Object, app As Object
    Set sfo = CreateObject("Scripting.FileSystemObject")
    Set app = CreateObject("Shell.Application")
    If sfo.FileExists(zippth) = True Then
        sfo.DeleteFile zippth
    End If
    With sfo.CreateTextFile(zippth, True)
        .Write "PK" & Chr(5) & Chr(6) & String(18, 0)
        .Close
    End With
    Dim zipfld As Object
    Set zipfld = app.Namespace(sfo.GetAbsolutePathName(zippth))
    Dim idx As Long, maxidx As Long: maxidx = UBound(pthary, 1)
    Dim n As Long: n = 0
    Dim f As Variant
    Dim start_tim As Date, cpyflg As Boolean
    For idx = 0 To maxidx
        cpyflg = False
        f = sfo.GetAbsolutePathName(pthary(idx))
        If is_folder(pthary(idx)) = True Then
            If app.Namespace(f).items().Count > 0 Then  '空フォルダでない？
                                                        '⇒空フォルダは圧縮できない
                cpyflg = True
            End If
        ElseIf Dir(pthary(idx)) <> "" Then
            cpyflg = True
        End If
        If cpyflg = True Then
            zipfld.CopyHere f, &H4 Or &H10
            n = n + 1
            'コピーが終わるのを待つ
            start_tim = Now
            Do Until zipfld.items().Count = n
                If DateDiff("s", start_tim, Now) > 5 Then    'タイムオーバー
                    Exit Function
                End If
                Debug.Print CStr(n) & "/" & CStr(zipfld.items().Count)
                Sleep 10
            Loop
        End If
    Next
    zip = True
Err:
    If Err.Number <> 0 Then
        Debug.Print "zip(): " & Err.Description
    End If
    Set sfo = Nothing
    Set app = Nothing
End Function

Public Function is_folder(pth As String) As Boolean
    is_folder = CreateObject("Scripting.FileSystemObject").FolderExists(pth)
End Function

上記関数の引数は、ptharyが圧縮対象のファイル/フォルダを配列で指定するのと、zippthでzipファイル名を指定。

空のzipファイルはマジック№とかを書いているだけ。
この空のzipファイルに、圧縮対象のファイルをコピーするのにはCopyHereを使用。
CopyHereは非同期で動いて、実行結果(エラーコードとか)も取れないみたいなので、
コピーできたかをカウンタを見て調べている。
途中でエラーになった場合は、カウンタが上がらないので、経過時間もチェックして、タイムオーバーになったら、
エラー終了すると言う実装。
あと、空フォルダを圧縮する(書庫に入れる)ことはできないので、空フォルダはスキップしている。