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

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][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)
'**************************************************
'フォルダパス及びフォルダ名取得再帰処理
'**************************************************
'無限ループ処理の為、フォルダやファイルの削除など行う場合は
'必ずバックアップを行って下さい。
'追加処理をした場合PCのハングアップの危険もあります。
'一応動作確認は行ってます。

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



パソコン工房

Production Japan Import Application. Since 1998