ZIP圧縮を織り交ぜながらフォルダをコピーするExcelマクロ

これは何か

ファイルパスの長さを考慮しZIP圧縮を織り交ぜながらフォルダをコピーするExcelマクロ

なぜ作ったか

事象：客先に成果物を納品するためのDVDを作成する際にエラーが発生
原因：フォルダの階層が深くなりパスの長さが255を超えたため
対処：適当なところでサブフォルダをZIP圧縮する

この「対処」を手動でやっていて面倒だったので自動化したかった

SpecialThanks/引用元

以下の記事を参考にさせていただきました
　VBA で Zip ファイルを作成する

注意

上記の記事をきっかけに、かねてからのアイディアを形にしてみましたが、
まだ実戦投入していないので、意図通りに動くか確認できていません
お気づきの点があればご指摘ください

コード

Option Explicit
' Microsoft Scripting Runtime
' Windows Script Host Object Model

Const MAX_LEN = 200
Const DOT_ZIP = ".zip"
Const DOT_PS1 = ".ps1"

Sub CopyOrArchive(fromDir, toDir)
    Dim fso As FileSystemObject
    Dim wsh As WshShell
    Dim fDic As Dictionary
    Dim cDic As Dictionary

    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsh = CreateObject("WScript.Shell")
    Set fDic = CreateObject("Scripting.Dictionary")
    Set cDic = CreateObject("Scripting.Dictionary")


   'コピー対象をDictionaryに格納する処理を呼び出す
    MakeDic fso.GetFolder(fromDir), fDic

   'PowerShellのコマンドを編集する
    Dim f, dest, cmd
    For Each f In fDic
        dest = Replace(f, fromDir, toDir, , 1, vbTextCompare) & fDic(f)
        cmd = IIf(fDic(f) = DOT_ZIP, "Compress-Archive", "Copy-Item")

        cDic.Add cDic.Count, Join(Array("New-Item", DQ(dest), "-Force"))
        cDic.Add cDic.Count, Join(Array(cmd, DQ(f), DQ(dest), "-Force"))
    Next

   'PowerShellのコマンドをファイルに出力し、実行する
    With fso
        Dim ps1
        ps1 = .BuildPath(.GetSpecialFolder(2), .GetTempName & DOT_PS1)
        With .CreateTextFile(ps1)
            .Write Join(cDic.Items, vbLf)
            .Close
        End With

        wsh.Run Join(Array("powershell", "-ExecutionPolicy", "RemoteSigned", "-File", DQ(ps1))) , 0, True

        .DeleteFile ps1, True
    End With


    Set fDic = Nothing
    Set cDic = Nothing
    Set fso = Nothing
    Set wsh = Nothing
End Sub

Function MakeDic(fol, dic)
   'コピー対象をDictionaryに格納する処理
    Dim f

   '直下のフォルダ・ファイルのパス長がひとつでも基準を超える場合は
   'このフォルダをZIP圧縮の対象として格納し、処理を抜ける
    dic(fol.Path) = DOT_ZIP
    For Each f In fol.SubFolders
        If Len(f.Path) > MAX_LEN Then Exit Function
    Next
    For Each f In fol.Files
        If Len(f.Path) > MAX_LEN Then Exit Function
    Next
    dic.Remove fol.Path

   '直下のフォルダ・ファイルのパス長が基準を超えない場合は
   'ファイルをコピー対象として格納し、サブフォルダは再帰処理する
    For Each f In fol.Files
        dic(f.Path) = vbNullString
    Next
    For Each f In fol.SubFolders
        MakeDic f, dic
    Next
End Function

Function DQ(strPath)
   'ファイルパスをダブルクォーテーションで囲む
    DQ = Replace("""*""", "*", strPath)
End Function

欄外

いっそ全部PowerShellで作れたら、とも思うが……