Dim Ans As Long
Dim tFsize As Long
Dim dirNo As Long, fileNo As Long
Dim fileNames() As String, fileNum As Long
Dim dirName As String, orgPath As String
Dim Dosyn As Long, Doexc As Long            ' 拡張子によるリストアップの除外・該当フラグ
Dim synExt() As String, excExt() As String  ' 除外・該当ファイル拡張子のリスト
Dim Date1 As String, Date2 As String        ' 除外するファイル作成日付


' 削除ボタン： 全て削除されるので注意
Private Sub Command1_Click()
Dim sFpath As String, soutFpath As String
Dim sProp As Integer        ' 再帰的ファイル検索の処理パラメータ 1: ファイルツリー作成  2：子フォルダまで全て削除
Dim sTmp As String
Dim j As Integer

    Ans = MsgBox("まず指定されたフォルダのファイルツリーを作成します。", vbOKCancel)
    If Ans = vbCancel Then Exit Sub
    
    sFpath = Text1.Text
    If Right(sFpath, 1) <> "\" Then sFpath = sFpath & "\"
    orgPath = sFpath
    
    dirNo = 0
    tFsize = 0
    fileNo = 0
    soutFpath = orgPath & "FTree.txt"
    sTmp = "<File Tree of : " & orgPath & ">"
    
    fileNum = 0
    ReDim fileNames(0)  ' 配列を初期化
    RecurseTree sFpath, 1
    
    ' ファイルツリーをファイルに書き出す
    Open soutFpath For Output As #1
    Print #1, sTmp; " : Files ="; fileNum; "  Total size ="; tFsize; "Bytes"
    For j = 0 To fileNum
        Print #1, Spc(4); fileNames(j)
    Next j
    fileNo = fileNo + fileNum
    dirNo = dirNo - 1       ' 指定されたフォルダはカウントしない
    Print #1, "<"; String(50, "-"); ">"
    Print #1, "<Total File Number : "; Tab(30); fileNo; " >"
    Print #1, "<Total Directory Number : "; Tab(30); dirNo; " >"
    Close #1
    Ans = MsgBox("指定されたフォルダの下には フォルダー： " & dirNo & " 個" & _
        vbCrLf & "ファイル： " & fileNo & " 個がありました。" & _
        vbCrLf & "続けてこのディレクトリの中身の削除を行いますか？", vbOKCancel)
    If Ans = vbCancel Then Exit Sub

    Ans = MsgBox("警告： 指定したフォルダ以下の全てのファイル／フォルダが削除されます ！！！", vbOKCancel)
    If Ans = vbCancel Then Exit Sub
    fileNum = 0
    ReDim fileNames(0)  ' 配列を初期化
    
    RecurseTree sFpath, 2
        ' ファイルツリーの作成と 削除 第2引数＝2 は削除の指定
    MsgBox "指定されたフォルダ以下の全てのフォルダ／ファイルは削除されました。"
    
    
End Sub
' 終了ボタン
Private Sub Command2_Click()

    Unload Me
End Sub


' ディレクトリ／ファイルの再帰的検索
' sProp=0:絶対パス＋File名   sProp=1:絶対パス＋File名＋Fileサイズ＋最終更新日付
' sProp=2:フォルダー内全削除
Sub RecurseTree(CurrentPath As String, sProp As Integer)
    Dim i As Integer, nI As Integer, nDirectory As Integer
    Dim sFileName As String, sDirectoryList() As String
    Dim sFilepath As String, fLen As Long
    Dim strtfNo As Long, endfNo As Long
    Dim sExt As String, subjP As Integer
    Dim j As Integer, sfDate As String
    Dim sSpace As String

    ' ① このディレクトリ内のすべての標準ファイルを列挙する
    CurrentPath = RTrim(CurrentPath)
    dirName = Right(CurrentPath, Len(CurrentPath) - Len(orgPath))
    sFileName = Dir(CurrentPath, vbNormal + vbReadOnly)
    ' 標準ファイルとリードオンリーファイルだけを対象とする
    dirNo = dirNo + 1
    strtfNo = fileNum
    Do While sFileName <> ""
        sFilepath = CurrentPath & sFileName
        sExt = Right(sFilepath, Len(sFilepath) - InStr(sFilepath, "."))
        sfDate = FileDateTime(sFilepath)
        If sProp = 2 Then      ' 削除の場合除外条件はなし
            subjP = 1
        Else
            If Dosyn = 1 Then
            ' 同期・除外拡張子に該当するか
                j = 0
                subjP = 0
                Do While synExt(j) <> ""
                    If sExt = synExt(j) Then
                        subjP = 1
                        Exit Do
                    Else
                        j = j + 1
                    End If
                Loop
            ElseIf Doexc = 1 Then
                j = 0
                subjP = 1
                Do While excExt(j) <> ""
                    If sExt = excExt(j) Then
                        subjP = 0
                        Exit Do
                    Else
                        j = j + 1
                    End If
                Loop
            Else
                subjP = 1
            End If
            ' 作成日付は指定範囲内か
            If Date1 <> "" Then
                If DateDiff("s", sfDate, Date1) > 0 Then subjP = 0
                ' 作成日付がDate1より前の場合は同期しない
            End If
            If Date2 <> "" Then
                If DateDiff("s", Date2, sfDate) > 0 Then subjP = 0
                ' 作成日付がDate2より後の場合は同期しない
            End If
        End If
        
        If subjP = 1 Then       ' 同期条件に一致したファイルがあった
            fLen = FileLen(sFilepath)
            tFsize = tFsize + fLen
            If sProp = 1 Then
                sSpace = String(48 - Len(dirName & sFileName) - Len(Str(fLen)), 32)
					' 上記48は桁揃え：フォルダ名と深さにより増減させないとエラーになる
                fileNames(fileNum) = dirName & sFileName & ";  " & sSpace & fLen & " Bytes;  " & sfDate
            ElseIf sProp = 2 Then
                fileNames(fileNum) = orgPath & dirName & sFileName
            Else
                fileNames(fileNum) = dirName & sFileName
            End If
            fileNum = fileNum + 1
            ReDim Preserve fileNames(fileNum)
        End If
        sFileName = Dir
    Loop
    endfNo = fileNum
    If sProp = 2 Then
    ' ディレクトリ内全ファイルの削除
        Do While endfNo > strtfNo
            Kill fileNames(endfNo - 1)
            endfNo = endfNo - 1
        Loop
        DelFldr (CurrentPath)
        ' フォルダが空だったら削除する Sub Routin
    End If
    ' ② 次に、サブディレクトリの一時的なリストを作る
    sFileName = Dir(CurrentPath, vbDirectory)
    Do While sFileName <> ""
        ' 現在のディレクトリと親ディレクトリを無視する
        If sFileName <> "." And sFileName <> ".." Then
            ' ディレクトリ以外を無視する
            If GetAttr(CurrentPath & sFileName) _
                    And vbDirectory Then
                nDirectory = nDirectory + 1
                ReDim Preserve sDirectoryList(nDirectory)
                sDirectoryList(nDirectory) = CurrentPath & sFileName
            End If
        End If
        sFileName = Dir
        ' 他のイベントを処理する
        DoEvents
    Loop
    ' 各ディレクトリを再帰的に処理する
    For nI = 1 To nDirectory
        RecurseTree sDirectoryList(nI) & "\", sProp
    Next nI
End Sub

' フォルダが空だったら削除する Sub Routin
Sub DelFldr(CurrentPath)
Dim sDirName As String, sParentD As String
Dim empDir As Integer, sIrgF As String
    
    sIrgF = Dir(CurrentPath, vbHidden + vbNormal + vbReadOnly + vbSystem)
    If sIrgF <> "" Then
        Ans = MsgBox("フォルダを削除しようとしましたが、バックアップフォルダに不正なファイルが残っています。" & _
            "< " & CurrentPath & "\" & sIrgF & " >" & vbCrLf & _
            vbCrLf & "フォルダの削除は完全ではありません。" & vbCrLf & _
            "必要に応じ削除してください。", vbOKOnly, "Caution !")
    Else
        sDirName = Dir(CurrentPath, vbDirectory)
        ' 注意：CurrentPath名は最後が "\"で終わっていないと自身がフォルダ名で帰される
        ' （．ではなく） ので注意が必要
        Do While sDirName <> ""
            If sDirName <> "." And sDirName <> ".." Then
            ' ルートディレクトリと親ディレクトリ以外があった
                empDir = 1
                Exit Do
            End If
            sDirName = Dir
        Loop
        If empDir = 0 Then
        ' フォルダが空の場合は、自身を削除し更に 親のディレクトリのチェックと削除をする
            sParentD = Left(CurrentPath, InStrRev(CurrentPath, "\", Len(CurrentPath) - 1))
            If CurrentPath <> orgPath Then
                RmDir (CurrentPath)
                If sParentD <> orgPath Then DelFldr (sParentD)
                ' 親ディレクトリがバックアップフォルダでない場合は再帰的に削除
            End If
        End If
    End If

End Sub