対象フォルダ配下サブフォルダ含めてファイルリストを取得したい、というニーズであまり使われないDir関数。
不具合あるからね。でもあまのじゃっきーだから一応書いてみる。
結果。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ファイル&フォルダでのテスト。
#つまり昨日と一緒.. :)
不具合あるからね。でもあまのじゃっきーだから一応書いてみる。
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
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ファイル&フォルダでのテスト。
#つまり昨日と一緒.. :)