see http://msdn2.microsoft.com/en-us/library/aa164475(office.10).aspx

Sub TestGetFiles()
  ' Call to test GetFiles function.

  Dim dctDict As Dictionary
  Dim varItem As Variant
 
  ' Create new dictionary.
  Set dctDict = New Dictionary
  ' Call recursively, return files into Dictionary object.
  If GetFiles("p:\chat", dctDict, True) Then
     ' Print items in dictionary.
     For Each varItem In dctDict
        Debug.Print varItem
     Next
  End If
End Sub
Function GetFiles(strPath As String, _
               dctDict As Dictionary, _
               Optional blnRecursive As Boolean) As Boolean
           
  ' This procedure returns all the files in a directory into
  ' a Dictionary object. If called recursively, it also returns
  ' all files in subfolders.
 
  Dim fsoSysObj      As FileSystemObject
  Dim fdrFolder      As Folder
  Dim fdrSubFolder   As Folder
  Dim filFile        As File
 
  ' Return new FileSystemObject.
  Set fsoSysObj = New FileSystemObject
 
  On Error Resume Next
  ' Get folder.
  Set fdrFolder = fsoSysObj.GetFolder(strPath)
  If Err <> 0 Then
     ' Incorrect path.
     GetFiles = False
     GoTo GetFiles_End
  End If
  On Error GoTo 0
 
  ' Loop through Files collection, adding to dictionary.
  For Each filFile In fdrFolder.Files
     dctDict.Add filFile.Path, filFile.Path
  Next filFile

  ' If Recursive flag is true, call recursively.
  If blnRecursive Then
     For Each fdrSubFolder In fdrFolder.SubFolders
        GetFiles fdrSubFolder.Path, dctDict, True
     Next fdrSubFolder
  End If

  ' Return True if no error occurred.
  GetFiles = True
 
GetFiles_End:
  Exit Function
End Function

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

   arfiles = Array()
   cnt = -1
   level = 1

   sFolder = "E:\"
   ReDim arfiles(2, 0)
   If sFolder <> "" Then
       SelectFiles sFolder
       Application.DisplayAlerts = False
       On Error Resume Next
       Worksheets("Files").Delete
       On Error GoTo 0
       Application.DisplayAlerts = True
       Worksheets.Add.Name = "Files"
       With ActiveSheet
           For i = LBound(arfiles, 2) To UBound(arfiles, 2)
               If arfiles(0, i) = "" Then
                   If fOutline Then
                       Rows(iStart + 1 & ":" & iEnd).Rows.Group
                   End If
                   With .Cells(i + 1, arfiles(2, i))
                       .Value = arfiles(1, i)
                       .Font.Bold = True
                   End With
                   iStart = i + 1
                   iEnd = iStart
                   fOutline = False
               Else
                   .Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
                                   Address:=arfiles(0, i), _
                                   TextToDisplay:=arfiles(1, i)
                   iEnd = iEnd + 1
                   fOutline = True
               End If
           Next
           .Columns("A:Z").ColumnWidth = 5
       End With
   End If
   'just in case there is another set to group
   If fOutline Then
       Rows(iStart + 1 & ":" & iEnd).Rows.Group
   End If

   Columns("A:Z").ColumnWidth = 5
   ActiveSheet.Outline.ShowLevels RowLevels:=1
   ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

   If FSO Is Nothing Then
       Set FSO = CreateObject("Scripting.FileSystemObject")
   End If

   If sPath = "" Then
       sPath = CurDir
   End If

   arPath = Split(sPath, "\")
   cnt = cnt + 1
   ReDim Preserve arfiles(2, cnt)
   arfiles(0, cnt) = ""
   arfiles(1, cnt) = arPath(level - 1)
   arfiles(2, cnt) = level

   Set oFolder = FSO.GetFolder(sPath)
   Set oFiles = oFolder.Files
   For Each oFile In oFiles
       cnt = cnt + 1
       ReDim Preserve arfiles(2, cnt)
       arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
       arfiles(1, cnt) = oFile.Name
       arfiles(2, cnt) = level + 1
   Next oFile

   level = level + 1
   For Each oSubFolder In oFolder.Subfolders
       SelectFiles oSubFolder.Path
   Next
   level = level - 1

End Sub