下層のファイルパス取得

2020/05/25

Excel2003

ファイルの位置より下層のファイル一覧を作成するVBA

Dim cnt As Long 'ファイル数カウント

'ファイルリスト作成
Sub CreateFileList()

    Dim rc As Integer
    msg = "本ファイルから下層のファイルリストを作成します。よろしいですか？"
    msg = msg & Chr(13) & "・ファイル数によっては長時間かかります"
    msg = msg & Chr(13) & "・処理を中断するにはEscを連打してください"

    rc = MsgBox(msg, vbYesNo + vbQuestion, "確認")
    If Not rc = vbYes Then
         MsgBox "処理を中断しました"
        Exit Sub
    End If

    '自動計算・警告表示の無効化
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    'リスト作成開始
    Dim WS As Worksheet
    Set WS = Worksheets.Add()

    'ファイルリスト作成
    cnt = 1
    Call FileListLower(ThisWorkbook.Path, WS)


    '自動計算・警告表示の有効化
    Application.StatusBar = False
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox ("処理が完了しました")

End Sub


Sub FileListLower(SearchPath As String, WS As Worksheet)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")

    'ファイルをリストに追加
    For Each f In FSO.GetFolder(SearchPath).Files
        WS.Cells(cnt, 1) = f.Path
        cnt = cnt + 1
        DoEvents 'フリーズ回避
    Next f

    'ステータスバー表示
    msg = cnt & "個のファイル発見。検索："
    If Len(SearchPath) < 150 Then '文字数制限対策
        Application.StatusBar = msg & SearchPath
    Else
        Application.StatusBar = msg & "（略）"
    End If

    '行数制限
    If cnt >= 65535 Then 'Excel2003 max.65536
        Application.StatusBar = False
        Exit Sub
    End If

    'フォルダ取得
    For Each f In FSO.GetFolder(SearchPath).SubFolders
        '下層制限
        If StrCount(f.Path, "\") <= 12 Then
            Call FileListLower(f.Path, WS)
        End If
    Next f

End Sub


Function StrCount(Source As String, Target As String) As Long
    Dim n As Long, cnt As Long
    Do
        n = InStr(n + 1, Source, Target)
        If n = 0 Then
            Exit Do
        Else
            cnt = cnt + 1
        End If
    Loop
    StrCount = cnt
End Function