特定フォルダ内のサブフォルダを全てチェックし、指定したものを削除する方法について への返答

投稿で使用できる特殊コードの説明。(別タブで開きます。)
本名は入力しないようにしましょう。
投稿した後で削除するときに使うパスワードです。返答があった後は削除できません。
返答する人が目安にします。相手が小学生か社会人かで返答の仕方も変わります。
最初の投稿が質問の場合、質問者が解決時にチェックしてください。(以降も追加書き込み・返信は可能です。)
※「過去ログ」について書くときはその過去ログのURLも書いてください。

以下の返答は逆順(新しい順)に並んでいます。

投稿者 TT  (社会人) 投稿日時 2012/5/21 13:37:32
投稿者です。

shuさま、魔界の仮面弁士さま、ご回答いただきありがとうございます。

shuさまの方法で希望する処理を行うことが出来ました。

お二人からご教示いただいたコードをさらに自分なりに検証して、理解できるようにしたいと思います。

お忙しいところをありがとうございました。
投稿者 魔界の仮面弁士  (社会人) 投稿日時 2012/5/18 15:16:31
> 条件は以下の通りです。
E・Fの下にあるファイルの仕様が不明ですが、こんな感じですか?


├B
│├2012_05_16
│├2012_05_17
│└2012_05_18
├C
│├2011_04_01
│├2011_04_02
│└2011_04_03
├D
│├G
││├2010_01_01
││├2010_02_01
││└2010_03_01
│└H
│ ├2010_01_31
│ ├2010_02_28
│ └2010_03_31
├E
│├2009_01_01
│├2009_02_01
│└2009_03_01
└F
 ├2010_12_29
 ├2010_12_30
 └2010_12_31



> サブフォルダ内のサブフォルダ、サブフォルダ内のサブフォルダ内のサブフォルダをチェックするロジック
FileSystemObject を使って処理するのであれば、Foler オブジェクトの SubFolder プロパティを
再帰的に処理していけば良いかと。

> 「yyyy_mm_dd」(作成日日付)フォルダと今日の日付の差を求めて削除するロジック
それでも求められますが、「今日の 90 日前の日づけ」を DateAdd 等で求めておき、
それを yyyy_mm_dd 化したものと大小比較した方がてっとり早い気がします。



以下、未検証ですがイメージコード。

"yyyy_mm_dd" 以外の命名規約のファイルがあった場合や、
アクセス権がらみのエラー対処などは盛り込んでいません。

Option Explicit

Call Main()

Sub Main()
  Dim limit
  limit = GetLimit()    ' = "2001_12_31" など。これより古いファイルを削除する。 

  Dim fileList, fso
  Set fileList = CreateObject("Scripting.Dictionary")
  Set fso = CreateObject("Scripting.FileSystemObject")

  Dim filePath  ' ここに、削除すべきファイル名の一覧が格納される 
  AddDeleteFiles fileList, fso.GetFolder("C:\temp\"), limit

  '列挙したファイルを削除する 
  For Each filePath In fileList.Keys   '.Keys → .Items でも可 
    fso.DeleteFile filePath, False
  Next
End Sub

Function GetLimit()
  Dim dt
  dt = DateAdd("d", -90, Date)    '90日前の日づけ 
  Dim ymd
  ymd = CStr(Year(dt) * 10000 + Month(dt) * 100 + Day(dt))
  '"20011231"を、"2001_12_31" 形式に変換 
  GetLimit = Mid(ymd, 1, 4) & "_" & Mid(ymd, 5, 2) & "_" & Mid(ymd, 7, 2)
End Function

Sub AddDeleteFiles(ByVal oDict, ByVal parentFolder, ByVal limit)
  Dim oFolder, oFile
  For Each oFolder In parentFolder.SubFolders
    AddDeleteFiles oDict, oFolder, limit
  Next
  For Each oFile In parentFolder.Files
    If oFile.Name <= limit Then
      oDict.Add oFile.ShortPath, oFile.Path
    End If
  Next
End Sub
投稿者 shu  (社会人) 投稿日時 2012/5/18 15:05:23
こんな感じでしょうか?

Option Explicit

Dim objFSO
Dim Folder
Dim SubFolders
Dim reg

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")

Set reg = New RegExp
reg.Pattern = "^(\d{4})_(\d{2})_(\d{2})$"

Set Folder = objFSO.GetFolder("A")
SubFolderParse Folder


Sub SubFolderParse(Folder)
    Dim SubFolder
    Dim PathName
    Dim CreateDate

    PathName = Folder.Name
    if reg.Test(PathName) then
        CreateDate = DateValue(reg.Replace(PathName,"$1/$2/$3"))
        WScript.Echo Folder.Path & ":" & DateDiff("d",CreateDate,Date)
        If DateDiff("d",CreateDate,Date) >= 90 then
            Folder.Delete True
        End If
    Else
        Set SubFolders = Folder.SubFolders

        For Each SubFolder in SubFolders
            SubFolderParse(SubFolder)
        Next
    End if
End Sub
投稿者 TT  (社会人) 投稿日時 2012/5/18 11:17:35
投稿者です。
バージョン情報が不足していましたので追記いたします。

当方、Win7、WindowsServer2008を使用しております。

よろしくお願いいたします。
投稿者 TT  (社会人) 投稿日時 2012/5/18 11:12:16
お世話になります。
標記の件につきまして、自己解決がどうしてもできませんでしたのでご教示いただけないでしょうか。

VBScriptを使用して、Aというフォルダに格納されているサブフォルダを全てチェック(検索)し、指定した条件に該当するものを削除したいのです。
条件は以下の通りです。

〇Aフォルダ直下には、Bフォルダ、Cフォルダ、Dフォルダ・Eフォルダ・Fフォルダが存在している。
〇B・Cフォルダ直下には「yyyy_mm_dd」(作成日日付)という名前でフォルダが作成されている。
〇Dフォルダ直下にはGフォルダ・Hフォルダが存在し、G・Hフォルダ直下に「yyyy_mm_dd」(作成日日付)という名前でフォルダが作成されている。
〇E・Fフォルダ直下にはファイルのみ存在し、フォルダは存在しない。

この条件の時、それぞれのフォルダ内にある「yyyy_mm_dd」(作成日日付)フォルダのうち今日の日付から90日以上前の作成日日付フォルダを削除したいのです。
ご教示いただきたいのは

サブフォルダ内のサブフォルダ、サブフォルダ内のサブフォルダ内のサブフォルダをチェックするロジック
「yyyy_mm_dd」(作成日日付)フォルダと今日の日付の差を求めて削除するロジック

上記の2点です。

なお、A~Hのフォルダは削除せずそのまま残しておきたいです。
質問する場が違うかもしれませんがご教示いただけますと幸いです。
よろしくお願いいたします。