I know this thread is a year old, but I was looking for a similar script. When I found yours, it was close to what I wanted, but I modified it to be able to handle a directory with ANY depth.
For some reason, I can't get the file to open correctly at the end, so I just left that part commented out and created a different message box. I also didn't need the files to be linked, so that's commented out, but it's easy to add back in. And I changed the name and location of the output file, but your location is still in there commented out.
One last thing, I added a check to see if the output folder exists. That's why I have 3 variables: outputFolder, outputFile, and outputTotal. OutputTotal is the other two connected into one variable.
Sub ShowSubFolders (Folder)
column = column + 1
For Each Subfolder in Folder.SubFolders
ObjXL.ActiveSheet.Cells(row,column).Value = Subfolder.Path
ObjXL.ActiveSheet.Cells(row,column).select
row = row + 1
ShowSubFolders Subfolder
Next
column = column - 1
End Sub
rootfolder = Inputbox("Enter CAF or folder path: " & chr(10) _
& "(e.g.\\Server\Root Folder Name\Folder\etc\)", _
"Directory Tree Generator", "C:\Temp\")
if rootfolder <> "" Then
outputFolder = "C:\Script Results\"
outputFile = "Folder Tree.xls"
outputTotal=outputFolder+outputFile
dim filesys, newfolder
set filesys=CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(outputFolder) Then
newfolder = filesys.CreateFolder (outputFolder)
End If
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set fso = CreateObject("scripting.filesystemobject")
if fso.fileexists(outputTotal) then fso.deletefile(outputTotal)
set objXL = CreateObject( "Excel.Application" )
objXL.Visible = False
objXL.WorkBooks.Add
column = 0
row = 1
ShowSubfolders FSO.GetFolder(rootfolder)
objXL.Range("A1").Select
objXL.Selection.EntireRow.Insert
objXL.Selection.EntireRow.Insert
objXL.Selection.EntireRow.Insert
objXL.Selection.EntireRow.Insert
objXL.Columns(1).ColumnWidth = 60
objXL.Columns(2).ColumnWidth = 40
objXL.Columns(3).ColumnWidth = 40
objXL.Columns(4).ColumnWidth = 40
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 = UCase(rootfolder)
objXL.Range("A1").Select
objXL.Selection.Font.Bold = True
ObjXL.ActiveWorkbook.SaveAs(outputTotal)
ObjXL.Application.Quit
Set ObjXL = Nothing
Finished = Msgbox ("File Map Generated Here:" & Chr(10) _
& outputfile & ".", 64, "File Map Generator")
end if
When I was done with that, I added the ability to get the files within those folders, and saved that as a different script. All of the main code remained the same, I just changed the subroutine and added another one for the files:
Sub ShowSubFolders (Folder)
column = column + 1
For Each Subfolder in Folder.SubFolders
ObjXL.ActiveSheet.Cells(row,column).Value = Subfolder.Path
ObjXL.ActiveSheet.Cells(row,column).select
row = row + 1
ShowSubFolders Subfolder
Next
ShowFiles Folder
column = column - 1
End Sub
Sub ShowFiles (Folder)
set files = folder.Files
For Each file in files
ObjXL.ActiveSheet.Cells(row,column).Value = file.Name
ObjXL.ActiveSheet.Cells(row,column).select
row = row + 1
next
End Sub
I tested the linking of the files, if you uncomment it, it will work.