ホーム‎ > ‎VBScriptの習作‎ > ‎

更新日が指定日数以上経過したファイルを再帰的に削除

Option Explicit


Const DaysOfDeletion   = 7                  '更新日が何日以上前のファイルを削除するか?

Const TargetFolderPath = "C:\temp\Z_SCAN"   '削除処理をする対象フォルダ


'-----------------------------------

' オブジェクト定義

'-----------------------------------

'Dim TargetFolderPath '削除対象フォルダ

'Dim DaysOfDeletion   '何日前のファイルを削除するか?の日数

Dim fso

Dim subf


Dim FileName   ' ファイル名

Dim FolderName ' フォルダ名

Dim FDate      ' ファイルの更新日


Set fso = CreateObject("Scripting.FileSystemObject")

Set subf = fso.GetFolder(TargetFolderPath)


'-----------------------------------

' メイン処理

'-----------------------------------

Dim StartMsg

Dim EndMsg

StartMsg = MsgBox("「" & TargetFolderPath & "」フォルダ内のファイルで更新日が" & DaysOfDeletion & "日以上前のものを削除します。" & vbCR & "削除処理を実行してもいいですか?",vbOKCancel,"古いファイルの削除") 

If StartMsg = vbOK Then

    'SCANフォルダ以外を間違って削除しないためのチェック

    If InStr(1,TargetFolderPath,"Z_SCAN", 1) > 0 Then 'フォルダ名に"Z_SCAN"が含まれる場合

        Call FileDel(subf)

    Else 'フォルダ名に"Z_SCAN"が含まれる場合

        EndMsg = MsgBox("SCANフォルダ以外を削除しようとしています。" & vbCR & "処理を中止していいですか?",vbOKOnly ,"古いファイルの削除")

        WScript.Quit

    End If

Else

    EndMsg = MsgBox("ファイル削除処理を中止します。",vbOKOnly ,"古いファイルの削除")

    WScript.Quit

End If

EndMsg = MsgBox("「" & TargetFolderPath & "」フォルダ内の" & DaysOfDeletion & "日以上前のファイルを削除しました。",vbOKOnly ,"古いファイルの削除")


'-----------------------------------

' 指定フォルダ直下のファイル削除処理

'-----------------------------------

Dim SubFolder1

Sub FileDel(SubFolder1)

    For Each FileName In SubFolder1.Files 'フォルダ内のファイル名を取得


        ' ファイルの更新日を取得

        fdate = FileName.DateLastModified

        ' 更新日から削除するか否かを判定

        if DateDiff("d", fdate, date) >= DaysOfDeletion then

            ' ファイル削除

            fso.DeleteFile FileName

        end if

    Next

    'サブフォルダがある際の処理

    Call FolderCheck(SubFolder1)

End Sub


'-----------------------------------

' サブフォルダがある際の処理

'-----------------------------------

Dim SubFolder2

Sub FolderCheck(SubFolder2)

    For Each FolderName In SubFolder2.Subfolders 'サブフォルダ名を取得

        'サブフォルダ内のファイル削除処理

        Call FileDel(FolderName)

    Next

End Sub


'-----------------------------------

' オブジェクト開放

'-----------------------------------

set fso = Nothing

Comments