Parsing Subdirectories

[Neil Ginsberg]

I need to write some code that will get all filenames under a particular
directory and add them to a table, including any in subdirectories. I
realize that Dir can be used to get all filenames in a directory; but how
does one parse an unlimited and unspecified number of subdirectories to get
all filenames? Any good code samples?

Thanks!

Neil

 

[Allen Browne]

As you found, Dir() cannot work recursively.

Here is a quick'n'dirty piece of code, adapted for Access VBA from VB code
Randy Birch published at www.mvps.org/vbnet

Paste it into a standard module, and save.

Create a table named "tblFile" to hold the file information. Fields:
FileID AutoNumber
Folder Text (255) directory name
FileName Text(255) name of file (without folder or ext)
FileExt Text(12) name of file extension

Open the Immediate Window (Ctrl+G), and enter:
? ListMyFiles("C:\MyPath")

-------------------------code begins-----------------------------
Private Const vbDot = 46
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type

Private Type FILE_PARAMS
bRecurse As Boolean
sFileRoot As String
sFileNameExt As String
sResult As String
sMatches As String
Count As Long
End Type

Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long)
As Long

Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA"
_
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" _
(ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Private rsTarget As DAO.Recordset
Private dtWhen As Date
Private lngFileCount As Long

Public Function ListMyFiles(strPath As String)
Dim FP As FILE_PARAMS 'holds search parameters

dtWhen = Now()
Set rsTarget = DBEngine(0)(0).OpenRecordset("tblFile")

'set up search params
With FP
.sFileRoot = strPath 'start path
.sFileNameExt = "*" 'file type
.bRecurse = True 'recursive search
End With
Call SearchForFiles(FP)

rsTarget.Close
Set rsTarget = Nothing
ListMyFiles = lngFileCount
End Function

Private Sub SearchForFiles(FP As FILE_PARAMS)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim strPath As String
Dim strRoot As String

strRoot = QualifyPath(FP.sFileRoot)
strPath = strRoot & "*.*"

'obtain handle to the first match
hFile = FindFirstFile(strPath, WFD)
If hFile <> INVALID_HANDLE_VALUE Then 'if valid ...
Call GetFileInformation(FP) 'obtains the file list and data for the
folder passed.
Do
'if the returned item is a folder...
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
If FP.bRecurse Then '..and the Recurse flag was specified
'and if the folder is not the default self and parent
folders (a . or ..)
If Asc(WFD.cFileName) <> vbDot Then
'..then the item is a real folder, which may contain
other sub folders, so assign
'the new folder name to FP.sFileRoot and recursively
call this function again with
'the amended information.
FP.sFileRoot = strRoot & TrimNull(WFD.cFileName)
'remove trailing nulls
Call SearchForFiles(FP)
End If
End If
End If
Loop While FindNextFile(hFile, WFD) 'continue until FindNextFile
returns 0.
hFile = FindClose(hFile) 'close the find handle
End If
End Sub

Private Sub GetFileInformation(FP As FILE_PARAMS)
'local working variables
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
Dim strPath As String
Dim strRoot As String
Dim strTemp As String
Dim lngPos As Long
Dim varExt As Variant

strRoot = QualifyPath(FP.sFileRoot) 'FP.sFileRoot contains the path to
search.
strPath = strRoot & FP.sFileNameExt 'FP.sFileNameExt contains the full
path and filespec.

'obtain handle to the first filespec match
hFile = FindFirstFile(strPath, WFD)
If hFile <> INVALID_HANDLE_VALUE Then 'if valid ...
Do
'Even though this routine uses file specs, *.* is still valid
and will cause the search
'to return folders as well as files, so a check against folders
is still required.
If Not (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) =
FILE_ATTRIBUTE_DIRECTORY Then
FP.Count = FP.Count + 1
strTemp = TrimNull(WFD.cFileName) 'remove trailing nulls
lngPos = InStrRev(strTemp, ".")
If lngPos > 1 Then 'Don't import if the last dot is in
the first place.
If lngPos > 0 And Len(strTemp) - lngPos < 6 Then
varExt = Mid(strTemp, lngPos + 1)
strTemp = Left(strTemp, lngPos - 1)
Else
varExt = Null
End If

With rsTarget
.AddNew
!Folder = Left(strRoot, Len(strRoot) - 1)
!FileName = strTemp
!FileExt = varExt
.Update
End With
lngFileCount = lngFileCount + 1&
' If lngFileCount Mod 100 = 0 Then
' 'DoCmd.Echo True, lngFileCount
' Debug.Print lngFileCount,
' End If
'Debug.Print Left(strRoot, Len(strRoot) - 1&), strTemp,
varExt
End If
End If
Loop While FindNextFile(hFile, WFD)
hFile = FindClose(hFile) 'close the handle
End If
End Sub

Public Function QualifyPath(strPath As String) As String
'assures that a passed path ends in a slash
If Right$(strPath, 1) <> "\" Then
QualifyPath = strPath & "\"
Else
QualifyPath = strPath
End If
End Function

Private Function TrimNull(strStringN As String) As String
'Purpose: Return a string up to the first null, if present, or the
passed string.
Dim lngPos As Long

lngPos = InStr(strStringN, vbNullChar)
If lngPos Then
TrimNull = Left$(strStringN, lngPos - 1)
Exit Function
End If
TrimNull = strStringN
End Function
--------------------------code ends------------------------------

 

[Albert D. Kallal]

Here is a short routine that will do what you want:

Sub dirTest()

Dim dlist As New Collection
Dim startDir As String
Dim i As Integer

startDir = "C:\access\"
Call FillDir(startDir, dlist)

MsgBox "there are " & dlist.Count & " in the dir"

' lets printout the stuff into debug window for a test

For i = 1 To dlist.Count
Debug.Print dlist(i)
Next i

End Sub


Sub FillDir(startDir As String, dlist As Collection)

' build up a list of files, and then
' add add to this list, any additinal
' folders

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant

strTemp = Dir(startDir)

Do While strTemp <> ""
dlist.Add startDir & strTemp
strTemp = Dir
Loop

' now build a list of additional folders
strTemp = Dir(startDir & "*.", vbDirectory)

Do While strTemp <> ""
If (strTemp <> ".") And (strTemp <> "..") Then
colFolders.Add strTemp
End If
strTemp = Dir
Loop

' now process each folder (recursion)
For Each vFolderName In colFolders
Call FillDir(startDir & vFolderName & "\", dlist)
Next vFolderName

End Sub


So, to add all data to a table, you can use:

Dim dlist As New Collection
Dim startDir As String
Dim i As Integer

startDir = "C:\access\"
Call FillDir(startDir, dlist)

MsgBox "there are " & dlist.Count & " in the dir"

dim rstRecs as dao.RecordSet

set rstRecs = currentdb.OpenrecordSet("tblOutput")

For i = 1 To dlist.Count
rstrecs.Add
rstRecs!dFileName = dlist(i)
rstRecs.update
Next i
rstRecs.Close

 

[Albert D. Kallal]

As you found, Dir() cannot work recursively.

Actually, you can use it..take look at my short recursive code posted....