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, 0
    
    ' ファイルツリーをファイルに書き出す
    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, 0
        ' ファイルツリーの作成と 削除 第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, Fldrdl 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
    Dim noFldr As Integer, noFile As Integer        ' Folder/File 存在フラグ
    Dim Fldrdld As Integer							' Folder削除完了フラグ
    
    ' ① このディレクトリ内のすべての標準ファイルを列挙する
    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
            noFile = 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)
                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
    ' ② 次に、サブディレクトリの一時的なリストを作る
    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
                noFldr = 1
            End If
        End If
        sFileName = Dir
        ' 他のイベントを処理する
        DoEvents
    Loop
    ' 各ディレクトリを再帰的に処理する
    For nI = 1 To nDirectory
        RecurseTree sDirectoryList(nI) & "\", sProp, Fldrdld
        If Fldrdld = 1 Then noFldr = 0
    Next nI
    If sProp = 2 Then
        If noFile = 1 And noFldr = 0 Then
        ' ファイルが存在していて、子フォルダがなく削除処理なら
        ' ディレクトリ内全ファイルの削除
            Do While endfNo > strtfNo
                Kill fileNames(endfNo - 1)
                endfNo = endfNo - 1
            Loop
            noFile = 0
        End If
        If noFile = 0 And noFldr = 0 Then
            ' フォルダが空(ファイルもフォルダもない)だったら削除する
             DelFldr CurrentPath, Fldrdl
        End If
    End If
    
End Sub

' フォルダが空だったら削除する Sub Routin
Sub DelFldr(CurrentPath As String, Fldrdl As Integer)
Dim sDirName 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
        If CurrentPath <> orgPath Then
            RmDir (CurrentPath)
            Fldrdl = 1
        End If
    End If
End Sub