FSO 指定ルートの配下全て(深階層まで)のファルダパスとフォルダ名取得(深階層まで)

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit

'**************************************************
'配下全てのThumbs.dbを削除するサンプル例
'**************************************************

Private lngRootCnt As Long
Private objFSO As Object
Private GetFileName As String '*処理
Private lngCnt As Long '*処理


Private Sub MakeSubFolderList()
'**************************************************
'指定ルートの配下全てのファルダパスとフォルダ名取得
'**************************************************

GetFileName = "Thumbs.db" '検索するファイル名'*処理

Dim strStartRoot As String

Set objFSO = New FileSystemObject

strStartRoot = ThisWorkbook.Path

lngRootCnt = 1

'再帰処理の為、サブルーチンをコールします
Call SubFolderSearch(strStartRoot)

Set objFSO = Nothing

End Sub

Private Sub SubFolderSearch(StartFolderPath As String)
'**************************************************
'フォルダパス及びフォルダ名取得再帰処理
'**************************************************
'無限ループ処理の為、フォルダやファイルの削除など行う場合は
'必ずバックアップを行って下さい。
'追加処理をした場合ＰＣのハングアップの危険もあります。
'一応動作確認は行ってます。

Dim SearchMainFolder As Folder
Dim SearchSubFolderA As Folder
Dim SearchSubFolderB As Folder

Dim objFolder As Object '*処理
Dim objFile As Object '*処理
Dim strFilePath As String '*処理
Dim strFileName As String '*処理

    '*処理---------------------------------------------------------------/
    'フォルダ直下
    With objFSO
    Set objFolder = .GetFolder(StartFolderPath)
    For Each objFile In objFolder.Files
        strFilePath = objFile.Path
        strFileName = .GetFileName(strFilePath)
            If InStr(1, strFileName, GetFileName) <> 0 Then
                If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then
                lngCnt = lngCnt + 1 '処理数
                '[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可
                    .GetFile(strFilePath).Delete
                End If
            End If
    Next
    Set objFolder = Nothing
    End With
    '*処理---------------------------------------------------------------/

    'フォルダ数
    lngRootCnt = lngRootCnt + 1

    With objFSO

        Set SearchMainFolder = .GetFolder(StartFolderPath)

        For Each SearchSubFolderA In SearchMainFolder.SubFolders

            '*処理---------------------------------------------------------------/
            'フォルダ直下
            Set objFolder = .GetFolder(SearchSubFolderA)
            For Each objFile In objFolder.Files
                strFilePath = objFile.Path
                strFileName = .GetFileName(strFilePath)
                    If InStr(1, strFileName, GetFileName) <> 0 Then
                        If MsgBox(strFilePath & vbNewLine & "Delete?", vbOKCancel, strFileName) = vbOK Then
                        lngCnt = lngCnt + 1 '処理数
                        '[Kill]関数では"Thumbs.db"等の特殊ファイルは削除不可
                            .GetFile(strFilePath).Delete
                        End If
                    End If
            Next
            Set objFolder = Nothing
            '*処理---------------------------------------------------------------/

            'フォルダ数
            lngRootCnt = lngRootCnt + 1

            If SearchSubFolderA.SubFolders.Count > 0 Then

                For Each SearchSubFolderB In SearchSubFolderA.SubFolders

                    Call SubFolderSearch(SearchSubFolderB.Path)

                Next SearchSubFolderB

            End If
        Next SearchSubFolderA

    End With

Set SearchMainFolder = Nothing
Set SearchSubFolderA = Nothing
Set SearchSubFolderB = Nothing

End Sub


Sub SetScrrunDLL()
'*****************************************************
'このコードが実装されたブックが「FileSystemObject」
'が使えるように参照設定をする。
'*****************************************************
On Error GoTo MyERROE:
'参照設定
ThisWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\system32\scrrun.dll"
MyERROE:
End Sub

 

2000年01月01日|[VBサンプルコード]:[FSO]