フォルダコピーとファイルの移動 ～ ⑦ まとめ ～

頂いた問い合わせに基づき一連のマクロを作成する過程を、前回までの
都合６回にわたりご紹介してきた。今回は、そのまとめを行う。

今回の要件は、纏めると以下のとおり。
【環境】

• フォルダＡ下に、フォルダＢ１，Ｂ２，・・・が存在する。
• その各々に、yyyymmdd（※年月日）フォルダが一つ存在する。
• さらにその下に、複数のファイルが存在する。

【要件】

1. フォルダＢ１，Ｂ２をループして、フォルダyyyymmddの日付と
   指定日の前後関係を確認する。
2. 例えばＢ１下のフォルダが指定日以前の場合、以下の操作を行う。
   ① Ｂ１の親フォルダＡを、あらかじめ指定した先に（なければ）作成する。
   ② Ｂ１を含む全てを、①で作成したフォルダ下に移動させる。
   ③ 移動後に、移動したファイルを一つずつ圧縮する（zip）。
   ④ 圧縮された元のファイルは削除する。
3. 2. の移動記録を出力する。
4. 処理の中断機能を設ける。ただし「非常停止」ではなく、実行中の
   最小ループ（多重ループの一番内側）を一回終えてからの終了とする。

各回のまとめが ↓ こちら。
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com
infoment.hatenablog.com

必要な参照設定は ↓ の二つ。

• Microsoft Scripting Runtime
• Windwos Script Host Object Library

遅延バインディングとする場合は、マクロの修正が必要。

その他

1. 移動ログを書き出すシートのオブジェクト名は「LogSheet」とする。
2. 移動ボタンはActiveXコントロールで作成。オブジェクト名は「cbMove」。
3. 中断ボタンもActiveXコントロールで作成。オブジェクト名は「cbStop」。
4. LogSheet内に、記録用テーブルを一つ準備。ラベル名は各回を参照のこと。
   ラベルの並び順や追加は任意に変更可。

今回作成したコードは、以下のとおり。
＜LogSheetに作成（シートモジュール）＞

Option Explicit

Private Sub cbMove_Click()
    Dim SpecifiedDate As Variant
        SpecifiedDate = InputBox("基準日を入力してください。", _
                                 "基準日入力", Date)
        If Not IsDate(SpecifiedDate) Then
            MsgBox "日付以外が入力されたため、処理を中断します。"
            Exit Sub
        End If
        
        ' 中断用フラグ初期化。
        StopFlag = False
    
    ' フォルダの移動。
    Call MoveFolders(CDate(SpecifiedDate))
    ' 圧縮と削除。
    Call ZipAndSourceDelete
End Sub

Private Sub cbStop_Click()
    StopFlag = True
End Sub

＜標準モジュールに作成＞

Option Explicit

' コピー元の親フォルダ。
Const SrcParentFolderPath As String = "C:\Temp\コピー元"
' コピー先の親フォルダ。
Const DstParentFolderPath As String = "C:\Temp\コピー先"
' FileSystemObject
Dim FSO As New Scripting.FileSystemObject
' 中断用フラグ。
Public StopFlag As Boolean

' 指定フォルダ下のファイルパスを全て取得。
Function FileList(folder_path As String) As Variant
    FileList = Filter(Split(CreateObject("wscript.shell").Exec("cmd /c Dir """ & folder_path & """ /b /s /a-d").StdOut.ReadAll, vbCrLf), ".")
End Function

Function IsMovable(folder_name As String, specified_date As Date) As Boolean
    Dim TargetDate As Date
        ' ８桁でない場合、引数に誤りあり。
        If Len(folder_name) <> 8 Then
            Exit Function
        End If
        ' ８桁の数字を日付に変換。
        TargetDate = Format(folder_name, "0000/00/00")
        ' 指定日以前であればTrue。
        IsMovable = (TargetDate < specified_date)
End Function

Function MoveTargetFolder(folder_a As String, folder_b As String, _
                          ByRef before_list As Variant, _
                          ByRef after_list As Variant) As Boolean
        On Error GoTo er:
    
    ' パス用配列の初期化。
        before_list = Array()
        after_list = Array()
    
    ' 移動する部分のフォルダパス。
    Dim MovePartName As String
        MovePartName = folder_a & "\" & folder_b

    ' 移動元のパス。
    Dim SrcFolderPath As String
        SrcFolderPath = FSO.BuildPath(SrcParentFolderPath, MovePartName)
    
    ' 移動先のパス。
    Dim DstFolderPath As String
        DstFolderPath = FSO.BuildPath(DstParentFolderPath, MovePartName)
    
    ' 階層Ａの移動先フォルダフルパス。
    Dim DstFolderAPath As String
        DstFolderAPath = FSO.BuildPath(DstParentFolderPath, folder_a)
    
    ' 移動先のフォルダ有無確認｡なければ作成する｡
        If Not FSO.FolderExists(DstFolderAPath) Then
            MkDir DstFolderAPath
        End If
    
    ' 移動前のパス取得。
        before_list = FileList(SrcFolderPath)
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
    
    ' 移動成功。
        MoveTargetFolder = True
    
    ' 移動後のパス取得。
        after_list = FileList(DstFolderPath)
        Exit Function
        
er:
    ' 移動失敗。
        MoveTargetFolder = False
End Function

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    ' 移動前リスト。
    Dim BeforeList As Variant
    ' 移動後リスト。
    Dim AfterList As Variant
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
  
        For Each FolderA In FSO.GetFolder(SrcParentFolderPath).SubFolders
            For Each FolderB In FSO.GetFolder(FolderA).SubFolders
                For Each FolderC In FSO.GetFolder(FolderB).SubFolders
                    If IsMovable(FolderC.Name, specified_date) Then
                        MoveTargetFolder FolderA.Name, FolderB.Name, _
                                         BeforeList, AfterList
                                       
                        ' 中断ボタンの押下検出用。
                        Application.Wait [Now()+"00:00:02"]
                        
                        ' 移動記録。
                        With Tb.ListRows.Add
                            .Range(2).Resize(UBound(BeforeList) + 1) = _
                                WorksheetFunction.Transpose(BeforeList)
                            If UBound(AfterList) <> -1 Then
                                .Range(3).Resize(UBound(AfterList) + 1) = _
                                    WorksheetFunction.Transpose(AfterList)
                            End If
                            .Range(5).Resize(UBound(BeforeList) + 1) = Now
                        End With
                        
                        ' 中断ボタンが押された時の処理。
                        DoEvents
                        If StopFlag Then
                            GoTo StopTrap:
                        End If
                            
                    End If
                Next
            Next
        Next
        
        Exit Sub
        
StopTrap:
    MsgBox "処理が中断されました。"
        
End Sub

Function Zip(source_path As String, _
             destination_path As String, _
    Optional source_del_flag As Boolean = True) As Boolean
    
    ' 参照設定：Windows Script Host Object Model
    Dim WshShell As IWshRuntimeLibrary.WshShell
    Set WshShell = New IWshRuntimeLibrary.WshShell
    Dim WshExec As IWshRuntimeLibrary.WshExec
    Dim Cmd As String
    
        ' 元データ（フォルダまたはファイル）の存在確認。
        If Not FSO.FileExists(source_path) And _
           Not FSO.FolderExists(source_path) Then
            Exit Function
        ' スペースがある場合も圧縮不可。
        ElseIf InStr(source_path, " ") <> 0 Then
            Exit Function
        End If
        
        ' 圧縮用コマンド作成。既に存在する場合は上書きする（-Force）。
        Cmd = "Compress-Archive -Path " & source_path & _
              " -DestinationPath " & destination_path & " -Force"
    
    ' 圧縮実行。
    Set WshExec = WshShell.Exec( _
        "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & Cmd)
    
        ' 圧縮失敗。
        If WshExec.Status = WshFailed Then Exit Function
    
        ' 圧縮完了まで待機。
        Do While WshExec.Status = WshRunning
            DoEvents
        Loop
        
        ' 圧縮前のデータを削除。
        If source_del_flag Then
            Kill source_path
        End If
    
        Zip = True
End Function

Sub ZipAndSourceDelete()
    ' 記録用テーブル。
    Dim Tb As ListObject
    Set Tb = LogSheet.ListObjects(1)
    
    ' 移動元パス配列。
    Dim SrcArray As Variant
        SrcArray = Tb.ListColumns("移動先パス").DataBodyRange
    
    ' 備考出力先。
    Dim NoteArray As Variant
        NoteArray = Tb.ListColumns("備考").DataBodyRange
    
    Dim i As Long
    Dim TempArray As Variant
    Dim DestinationPath As String
        For i = 1 To UBound(SrcArray)
            ' ファイルの存在確認。
            If Not FSO.FileExists(SrcArray(i, 1)) Then
            ' 既に圧縮されているか否かの確認。
            ElseIf StrConv(Right(SrcArray(i, 1), 4), _
                           vbNarrow + vbLowerCase) = ".zip" Then
            Else
                ' 拡張子を除去するため、一旦"."で分割。
                TempArray = Split(SrcArray(i, 1), ".")
                ' 分割結果の要素数を一つ減らすことで、拡張子を除去。
                ReDim Preserve TempArray(UBound(TempArray) - 1)
                ' "."で結合して末尾に".zip"を追加し、圧縮後バスを作成。
                DestinationPath = Join(TempArray, ".") & ".zip"
                
                If Zip(CStr(SrcArray(i, 1)), DestinationPath) Then
                    '圧縮が成功したならば、圧縮後のパスに置き換える。
                    SrcArray(i, 1) = DestinationPath
                    NoteArray(i, 1) = "圧縮成功"
                Else
                    NoteArray(i, 1) = "圧縮失敗"
                End If
            End If
        Next
        
        ' 結果の出力。
        Tb.ListColumns("移動先パス").DataBodyRange = SrcArray
        Tb.ListColumns("備考").DataBodyRange = NoteArray
End Sub

＜注意＞（免責事項）
今回は初期設定で、最終的にファイルの削除を行っている。従ってこれを参照し、実務や何某かで実行される場合は、意図せずデータが失われないよう充分に注意してほしい。
※その辺り、こちらでは責任を負いかねますので、充分にテストしたうえで、自己責任の範囲で使用願います。

＜感想＞
ファイルの圧縮操作部分は、今回初めて学んだことが多かったです。
とても勉強になりました。

以上、ご参考まで。