Help us understand the problem. What is going on with this article?

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で作れたら、とも思うが……

Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした