FolderLister

Sub ShowSubFolders (Folder, Depth)  
column = 1
If Depth > 0 then        
For Each Subfolder in Folder.SubFolders            
ShowSubFolders Subfolder, Depth - 1        

ObjXL.ActiveSheet.Cells(icount,column).Value = Subfolder.Path
ObjXL.ActiveSheet.Cells(icount,column).select
CAFLink = Subfolder.Path
ObjXL.Workbooks(1).Worksheets(1).Hyperlinks.Add ObjXL.Selection, CAFLink
icount = icount + 1

Next    

End if
End Sub
' Specify Folder Depth (D)
D = 2
' Get CAF Path from user (rootfolder)
rootfolder = Inputbox("Enter CAF or folder path: " & chr(10) & "(e.g.\\Server\Root Folder Name\Folder\etc\)" & chr(10) & _
 chr(10) & "Folder Depth Currently Set to " & D & " folder levels " & chr(10), _
"Directory Tree Generator", "C:\Temp\")
'Run ShowSubFolders if something was entered in the CAF directory field, else just end
if rootfolder <> "" Then

outputfile = "C:\Temp\" & Year(now) & Month(now) & Day(now) & "DIR_MAP_V1.0.xlsx"
Set fso = CreateObject("scripting.filesystemobject")
if fso.fileexists(outputfile) then fso.deletefile(outputfile)

'Create Excel workbook
set objXL = CreateObject( "Excel.Application" )
objXL.Visible = False
objXL.WorkBooks.Add
'Counter 1 for writing in cell A1 within the excel workbook
icount = 1
'Run ShowSubfolders - D is the folder depth to parse
ShowSubfolders FSO.GetFolder(rootfolder), D  

'Lay out for Excel workbook
  objXL.Range("A1").Select
  objXL.Selection.EntireRow.Insert
  objXL.Selection.EntireRow.Insert
  objXL.Selection.EntireRow.Insert
  objXL.Selection.EntireRow.Insert
  objXL.Selection.EntireRow.Insert

  objXL.Columns(1).ColumnWidth = 90
  objXL.Range("A1").NumberFormat = "d-m-yyyy"
  objXL.Range("A1:A3").Select
  objXL.Selection.Font.Bold = True
  objXL.Range("A1:B3").Select
  objXL.Selection.Font.ColorIndex = 5
  objXL.Range("A2").Select
  ObjXL.ActiveSheet.Cells(1,1).Value = Day(now) & "-" & Month(now) & "-"& Year(now)
  ObjXL.ActiveSheet.Cells(2,1).Value = "DIRECTORY MAP FOLDER DEPTH:- " & D  
  ObjXL.ActiveSheet.Cells(3,1).Value = UCase(rootfolder)
  objXL.Range("A1").Select
  objXL.Selection.Font.Bold = True
'Finally close the workbook
  ObjXL.ActiveWorkbook.SaveAs(outputfile)
  ObjXL.Application.Quit
  Set ObjXL = Nothing
'Message when finished
  Set WshShell = CreateObject("WScript.Shell")
  Finished = Msgbox ("CAF Map Generated Here:-" & Chr(10) _
& outputfile & "." & Chr(10) _
& "Do you want to open the Folder Map now?", 65, "DIRECTORY Map Generator")
  if Finished = 1 then WshShell.Run "excel " & outputfile

end if