フォルダコピーとファイルの移動 ~ ③ 連続で処理 ~
昨日は、あるフォルダを別のフォルダへ移動するところまで作成した。
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 ' 8桁でない場合、引数に誤りあり。 If Len(folder_name) <> 8 Then Exit Function End If ' 8桁の数字を日付に変換。 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) ' 階層Aの移動先フォルダフルパス。 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) ' 階層Aのフォルダループ用。 Dim FolderA As Scripting.Folder ' 階層Bのフォルダループ用。 Dim FolderB As Scripting.Folder ' 階層Cのフォルダループ用。 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より前の日付名を持つB1,B2のみ、コピー先へ移動するはず。
上手くいったようだ。
明日に続きます。
参考まで。