Macro to enumerate subdirs and files in a directory!

  • Thread starter Thread starter bookworm98
  • Start date Start date
This is not my code. I cannot remeber who authored it - PSC maybe.

Private Sub Path()
On Error GoTo handle
Dim fso, fs, f, x
Set fso = CreateObject("scripting.filesystemobject") 'create
filesystemobject
Set fs = fso.getfolder("c:\") 'gets a hanlde on th
path
' cange as appropriate
Set f = fs.subfolders 'gets a list of al
the folders in the path
Set x = fs.files 'gets a list of al
the files in the path

For Each w In f 'for..next loop
'w this point is the folders in the directory
'for every folder in the list, add it to the subfolder
listbox

' your code here

Next 'loop

For Each v In x
'v lists the files in each folder

' your code here

Next
Exit Sub
handle:
msg = MsgBox("An error has been found. Make sure that the driv
and path exist.", vbCritical, "Error")
End Su
 
Bookworm98,


Here's one I put together a while ago - it could do with some optimising,
but I was using it for a once-off task so wasn't fussy.


Sub test()
Dim arr() As String, i As Long

arr = RecursiveDir("C:\WINDOWS\")

For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next
End Sub

Function RecursiveDir(Path As String, Optional Attributes As
VbFileAttribute) As String()
Dim strPath As String, strResult As String, i As Long, j As Long, k As
Long
Dim arrPath() As String, arrFile() As String, arrTemp() As String

On Error Resume Next

strPath = Path
If Right(strPath, 1) <> Application.PathSeparator Then strPath = strPath
& Application.PathSeparator

strResult = Dir(strPath, vbDirectory Or Attributes)
Do Until strResult = ""
If GetAttr(strPath & strResult) And vbDirectory Then
If Not (strResult = "." Or strResult = "..") Then
i = UBound(arrPath) + 1
If CBool(Err.Number) Then
Err.Clear: i = 0
End If
ReDim Preserve arrPath(i)
arrPath(i) = strPath & strResult & Application.PathSeparator
End If
Else
i = UBound(arrFile) + 1
If CBool(Err.Number) Then
Err.Clear: i = 0
End If
ReDim Preserve arrFile(i)
arrFile(i) = strPath & strResult
End If
strResult = Dir
Loop

i = LBound(arrPath)
If Not CBool(Err.Number) Then
For i = LBound(arrPath) To UBound(arrPath)
arrTemp = RecursiveDir(arrPath(i), Attributes)
j = LBound(arrTemp)
If Not CBool(Err.Number) Then
For j = LBound(arrTemp) To UBound(arrTemp)
k = UBound(arrFile) + 1
If CBool(Err.Number) Then
Err.Clear: k = 0
End If
ReDim Preserve arrFile(k)
arrFile(k) = arrTemp(j)
Next
Else
Err.Clear
End If
Next
Else
Err.Clear
End If

arrTemp = arrPath

i = LBound(arrFile)
If Not CBool(Err.Number) Then
For i = LBound(arrFile) To UBound(arrFile)
j = UBound(arrTemp) + 1
If CBool(Err.Number) Then
Err.Clear: j = 0
End If
ReDim Preserve arrTemp(j)
arrTemp(j) = arrFile(i)
Next
Else
Err.Clear
End If

RecursiveDir = arrTemp
End Function


Rob
 
Back
Top