■Dir再帰|非再帰

対象フォルダ配下サブフォルダ含めてファイルリストを取得したい、というニーズであまり使われないDir関数。
不具合あるからね。でもあまのじゃっきーだから一応書いてみる。

Option Explicit

Private Const cPath As String = "C:¥WORK¥" '対象フォルダパス
Private Const MX　　As Long = 100000　　　 '取得用配列サイズ大きめに
Private fList()　　 As String　　　　　　　'ファイル名取得用配列
Private idx　　　　 As Long　　　　　　　　'配列Index
'-------------------------------------------------
Private Sub test() 'テストプロシージャ選択用
　　Dim t As Single
　　t = Timer

　　Call TestDirRecur

　　Debug.Print idx & " files", Timer - t
End Sub
'-------------------------------------------------
Private Sub TestDirRecur() '再帰版
　　Dim sPath As String
　　ReDim fList(1 To MX, 0)

　　sPath = cPath
　　idx = 0
　　Call DirRecur(sPath)
　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList
End Sub
Private Sub DirRecur(sPath As String)
　　Dim sList(1 To 1000) As String
　　Dim fPath As String
　　Dim ret　 As String
　　Dim si　　As Long
　　Dim i　　 As Long

　　On Error GoTo ErrH:
　　ret = Dir(sPath, vbDirectory Or vbReadOnly _
　　　　　　　　　　 Or vbHidden Or vbSystem)
　　Do Until Len(ret) = 0
　　　　If ret <> "." And ret <> ".." Then
　　　　　　idx = idx + 1
　　　　　　fPath = sPath & ret
　　　　　　fList(idx, 0) = fPath
　　　　　　If GetAttr(fPath) And vbDirectory Then
　　　　　　　　si = si + 1
　　　　　　　　sList(si) = fPath & "¥"
　　　　　　End If
　　　　End If
　　　　ret = Dir()
　　Loop

　　For i = 1 To si
　　　　Call DirRecur(sList(i))
　　Next

　　Exit Sub

ErrH:
　　'Debug.Print fPath
　　'Debug.Print Err.Number, Err.Description
　　Resume Next
End Sub
'-------------------------------------------------
Private Sub TestDirLoop()　'非再帰版
　　Dim sPath As String
　　Dim fPath As String
　　Dim ret　 As String
　　Dim i　　 As Long
　　Dim j　　 As Long
　　Dim d(1 To MX) As Long 'サブフォルダidx記憶用
　　ReDim fList(1 To MX, 0)

　　On Error GoTo ErrH:
　　sPath = cPath
　　idx = 0
　　Do
　　　　ret = Dir(sPath, vbDirectory Or vbReadOnly _
　　　　　　　　　　　　 Or vbHidden Or vbSystem)
　　　　Do Until Len(ret) = 0
　　　　　　If ret <> "." And ret <> ".." Then
　　　　　　　　idx = idx + 1
　　　　　　　　fPath = sPath & ret
　　　　　　　　fList(idx, 0) = fPath
　　　　　　　　If GetAttr(fPath) And vbDirectory Then
　　　　　　　　　　i = i + 1
　　　　　　　　　　d(i) = idx
　　　　　　　　End If
　　　　　　End If
　　　　　　ret = Dir()
　　　　Loop

　　　　j = j + 1
　　　　If j > i Then Exit Do
　　　　sPath = fList(d(j), 0) & "¥"
　　Loop

　　'Sheets.Add.Range("A1").Resize(idx).Value = fList
　　Erase fList

　　Exit Sub

ErrH:
　　'Debug.Print fPath
　　'Debug.Print Err.Number, Err.Description
　　Resume Next
End Sub

結果。Unicode文字あるとGetAttr関数のところでエラーになるし、256Byteあたりの制限ありますよね..
なので実用的ではないけど..一応。

[TestDirRecur]
20000 files　　1.375
20000 files　　1.359375
20000 files　　1.359375

[TestDirLoop]
20000 files　　1.390625
20000 files　　1.359375
20000 files　　1.34375

C:\WORK配下のフォルダは最大10階層。
20,000ファイル＆フォルダでのテスト。
#つまり昨日と一緒.. :)