Take a look at the FileSearch object in Word VBA. it allows you to search a
folder hierarchy for files. You set the SearchSubfolders property to True
for that purpose. You'll find code examples in the Help.

Hi,

I have code that will return all the file names of a specified type from a
directory that you select. I created two modules to handle this:
AllDocsInFolderTree and DirectoryListArray (almost all of the code, though,
comes from the MVPs site).
In the module AllDocsInFolderTree, I have the following code (the first
routine calls other functions which call other functions). In "Public
Function fGetFolder(sFolderName As String)", make sure that you specify what
file extension you want to look for.
Good luck.

Option Explicit

Sub GetAllDocsFromFolderTree()
With Dialogs(wdDialogCopyFile)
   If .Display <> 0 Then
       fGetFolder sFolderName:=Replace(.directory, Chr(34), "")
   Else
       MsgBox "Dialog cancelled"
   End If
End With
End Sub

Public Function fGetFolder(sFolderName As String)

Dim FoldersArray As Variant
Dim aFileNames As Variant
Dim lCounter As Long
Dim oDoc As Document
Dim i As Integer
Debug.Print sFolderName
'Read all subfolders of the specified folder into an array
'by calling the funcGetSubfolders function

FoldersArray = funcGetSubfolders(sFolderName)

'Put the results (the array values) into a new document
Set oDoc = Documents.Add

For i = LBound(FoldersArray) To UBound(FoldersArray)
   aFileNames = DirectoryListArray.fDirectoryListArray _
       (sPath:=CStr(FoldersArray(i)), _
       sExtension:=".doc")
   If UBound(aFileNames) > 0 Then
       For lCounter = LBound(aFileNames) To UBound(aFileNames)
           oDoc.Range.InsertAfter text:=FoldersArray(i) &
aFileNames(lCounter) & vbCrLf
       Next lCounter
   End If
Next i
ActiveDocument.Saved = True
End Function

Public Function funcGetSubfolders(ByVal FolderToRead As String) As Variant

'This function uses a string as a parameter and not an array.
'It translates this string to an array and then starts the main function,
'funcGetAllSubfolders'

Dim AllSubFolders(0) As Variant

On Error Resume Next
System.Cursor = wdCursorWait

'Add a backslash to  the end of the path, if not there already
If (Right$(FolderToRead, 1) <> "\") Then
   FolderToRead = FolderToRead & "\"
End If

'Set the path as the first entry in the array and pas the array to the main
function
AllSubFolders(0) = FolderToRead
funcGetSubfolders = funcGetAllSubfolders(AllSubFolders)

System.Cursor = wdCursorNormal
StatusBar = ""
On Error GoTo 0

End Function

Private Function funcGetAllSubfolders(ByVal AllSubFoldersArray As Variant)
As Variant

'This is a recursive function, that is, it keeps calling itself -
'which makes it a nightmare to step through!

Dim Counter As Integer

'The following string will contain the path of the folder which is currently
being looked in
Dim CurFolderName As String

'The following string will contain the current value returned by Dir$().
Dim SubFolderName As String

'The following array will contain of the subfolders (if any) of
'CurFolderName'
Dim SubFolderList() As String

On Error Resume Next

'Get the last value we put into the AllSubFoldersArray Array variant,
'and convert it to a string so that we can assign it to the string
'variable CurFolderName
CurFolderName = CStr(AllSubFoldersArray(UBound(AllSubFoldersArray)))

'Read all subfolders of 'CurFolderName' and add them to 'SubFolderList'.
ReDim SubFolderList(0)
SubFolderName = Dir$(CurFolderName, vbDirectory)
Do While Len(SubFolderName) <> 0
   'Ignore the current directory and the encompassing directory.
   If SubFolderName <> "." And SubFolderName <> ".." Then
       'Unfortunately, calling Dir with the vbDirectory attribute
       'does not continually return subdirectories (only the first time);
       'so you have to use the GetAttr function (which is covered in Help)
       'to test, each time, that this is a folder and not a file
       If (GetAttr(CurFolderName & SubFolderName) _
               And vbDirectory) = vbDirectory Then
           'Up the array size by one
           ReDim Preserve SubFolderList(UBound(SubFolderList) + 1)
           'Add the new folder to the array
           SubFolderList(UBound(SubFolderList)) = SubFolderName
           StatusBar = "Reading Subfolders... (" _
                   & CurFolderName & ": -> " & SubFolderName & ")"
       End If
   End If
   'Get the next directory
   SubFolderName = Dir$()
Loop

'Sort the list with the subfolders.
If UBound(SubFolderList) > 0 Then
   WordBasic.SortArray SubFolderList()
End If

'Now get all the subfolders of the current folder, then all the subfolders
'of each of those subfolders, and so on, up the directory tree,
'until there are no more subfolders. By recursively
'(repeatedly applying the procedure to successive results)
'calling the current function.

'If the current folder contains no subfolders, the following For .. Next
loop gets skipped

For Counter = 1 To UBound(SubFolderList)

   'Up the size of the AllSubFoldersArray array by one
   ReDim Preserve AllSubFoldersArray(UBound(AllSubFoldersArray) + 1)

   'Set the next item in the AllSubFoldersArray to be
   'the next subfolder of the current folder
   AllSubFoldersArray(UBound(AllSubFoldersArray)) = _
           CurFolderName & SubFolderList(Counter) & "\"

   'Now run the this function recursively on that subfolder,
   'to get its subfolders, if it has any
   AllSubFoldersArray = funcGetAllSubfolders(AllSubFoldersArray)
Next Counter

'Set the complete directory structure as the function's  return value.
funcGetAllSubfolders = AllSubFoldersArray
On Error GoTo 0

End Function

IN the DirectoryListArry module, I have the following code
Option Explicit

Public Function fDirectoryListArray( _
   sPath As String, _
   sExtension As String) As Variant
Dim MyFile As String
Dim Counter As Long

'Create a dynamic array variable, and then declare its initial size
Dim DirectoryListArray() As String
ReDim DirectoryListArray(1000)
Counter = 0
'Loop through all the files in the directory by using Dir$ function
MyFile = Dir$(sPath & "*" & sExtension)
Debug.Print sPath & "*" & sExtension
Do While MyFile <> ""
   DirectoryListArray(Counter) = MyFile
   MyFile = Dir$
   Counter = Counter + 1
Loop

'Reset the size of the array without losing its values by using Redim
Preserve
If Counter <> 0 Then
   ReDim Preserve DirectoryListArray(Counter - 1)
Else
   ReDim Preserve DirectoryListArray(0)
End If

fDirectoryListArray = DirectoryListArray

End Function

Public Sub UseDirectoryListArray()
Dim aDir As Variant
Dim iCount As Integer
Dim oDoc As Document

Set oDoc = Documents.Add

aDir = fDirectoryListArray(sPath:="C:\Documents and Settings\DLett\My
Documents\", sExtension:=".doc")
For iCount = 0 To UBound(aDir)
   oDoc.Range.InsertAfter aDir(iCount) & vbCrLf
Next iCount
End Sub

HTH,
Dave

On firefox I can's see the original formatting I included in the previous post

maindirectory level1
userid1 level2
subdirectory1 level3
subdirectory2 level3
userid2 level2
subdirectory1 level3
subdirectory2 level3
etc...