フォルダコピーとファイルの移動 ～ ③ 連続で処理 ～

昨日は、あるフォルダを別のフォルダへ移動するところまで作成した。
infoment.hatenablog.com
今日も、昨日の続きから。

今回は、指定フォルダ下にある判定対象フォルダを、連続で処理してみる。
各フォルダの名前を取得して判定などに使用するわけで、検討の過程で
先日作成したIsMovable関数を、もう少しだけ簡素化してみた。

Option Explicit

' コピー元の親フォルダ。
Const SrcParentFolderPath As String = "C:\Temp\コピー元"
' コピー先の親フォルダ。
Const DstParentFolderPath As String = "C:\Temp\コピー先"
' FileSystemObject
Dim FSO As New Scripting.FileSystemObject

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

単一処理の部分がこちら（昨日分を再掲）。

Sub MoveTargetFolder(folder_a As String, folder_b As String)
    ' 移動する部分のフォルダパス。
    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
    
    ' フォルダ移動。
        FSO.MoveFolder SrcFolderPath, DstFolderPath
End Sub

そして、これをループさせて連続処理するのがこちら。指定日は引数で
与えることとした。

Sub MoveFolders(specified_date As Date)
    ' 階層Ａのフォルダループ用。
    Dim FolderA As Scripting.Folder
    ' 階層Ｂのフォルダループ用。
    Dim FolderB As Scripting.Folder
    ' 階層Ｃのフォルダループ用。
    Dim FolderC As Scripting.Folder
    
        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
                    End If
                Next
            Next
        Next
End Sub

それでは、早速テストしてみよう。

Sub test()
    MoveFolders #8/1/2022#
End Sub

想定では8/1より前の日付名を持つＢ１，Ｂ２のみ、コピー先へ移動するはず。

上手くいったようだ。

明日に続きます。

参考まで。