Click here to Skip to main content
15,867,488 members
Please Sign up or sign in to vote.
0.00/5 (No votes)
See more:
I have tried to write a vb script to get the folder structure of a directory (and sub folders) and output the structure to excel. I can do it in a list form but would like the directory tree indented in excel so you can see the folder hierarchy.

Here is my code so far:


VB
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 = 3
' 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.xls"
		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


So this outputs a nice list of clickable folders in a single column, but I want to try and indent it so the folder hierarchy is visible.

CAn anyone help me out here?

Thanks
Posted
Updated 28-Mar-11 21:36pm
v2

Hope this helps -- I'll leave the formatting of the columns to you. I only modified a few lines -- added the
"revcol" and "Top" vars to the ShowSubFolders sub to reorder the columns from left to right. (Also added three columnwidth settings for cols B-D just for looks.)
VB
Sub ShowSubFolders (Folder, Depth, Top) 
	column = Depth
	revcol = Top + 1 - column
	If Depth > 0 then 
		For Each Subfolder in Folder.SubFolders 
			ObjXL.ActiveSheet.Cells(icount,revcol).Value = Subfolder.Path
			ObjXL.ActiveSheet.Cells(icount,revcol).select
			CAFLink = Subfolder.Path 
			ObjXL.Workbooks(1).Worksheets(1).Hyperlinks.Add ObjXL.Selection, CAFLink 
			ShowSubFolders Subfolder, Depth - 1, Top
			icount = icount + 1
		Next 
	End if 
End Sub 
' Specify Folder Depth (D)
D = 3
' 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.xls"
	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 , D
	'Lay out for Excel workbook (top 5 rows as header)
	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 = 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 = "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
 
Share this answer
 
v2
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.

VB
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
		'CAFLink = Subfolder.Path 
		'ObjXL.Workbooks(1).Worksheets(1).Hyperlinks.Add ObjXL.Selection, CAFLink 
		row = row + 1
		ShowSubFolders Subfolder
	Next 
		
	column = column - 1
End Sub 

' Get CAF Path from user (rootfolder)
rootfolder = Inputbox("Enter CAF or folder path: " & chr(10) _
	& "(e.g.\\Server\Root Folder Name\Folder\etc\)", _
	"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.xls"
	outputFolder = "C:\Script Results\"
	outputFile = "Folder Tree.xls"
	outputTotal=outputFolder+outputFile

	'check if folder exists, if not, create it
	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)
	'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
	column = 0
	row = 1
	'Run ShowSubfolders
	ShowSubfolders FSO.GetFolder(rootfolder)
	'Lay out for Excel workbook (top 4 rows as header)
	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
	'Finally close the workbook
	ObjXL.ActiveWorkbook.SaveAs(outputTotal)
	ObjXL.Application.Quit
	Set ObjXL = Nothing
	
	Finished = Msgbox ("File Map Generated Here:" & Chr(10) _
		& outputfile & ".", 64, "File Map Generator")
	'Message when finished
	'Set WshShell = CreateObject("WScript.Shell")
	'Finished = Msgbox ("Folder Map Generated Here:" & Chr(10) _
		'& outputTotal & "." & Chr(10) _
		'& "Do you want to open the Folder Map now?", 65, "DIRECTORY Map Generator")
	'if Finished = 1 then 
	
	'CreateObject("WScript.Shell").Run outputTotal	
	'WshShell.Run "excel " & outputTotal
	
	
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:

VB
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
		'CAFLink = Subfolder.Path 
		'ObjXL.Workbooks(1).Worksheets(1).Hyperlinks.Add ObjXL.Selection, CAFLink 
		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
		'CAFLink = Folder.Path+"\"+file.name
		'ObjXL.Workbooks(1).Worksheets(1).Hyperlinks.Add ObjXL.Selection, CAFLink 
		row = row + 1
	next
End Sub


I tested the linking of the files, if you uncomment it, it will work.
 
Share this answer
 
Thanks, Just what I was looking for
 
Share this answer
 

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)



CodeProject, 20 Bay Street, 11th Floor Toronto, Ontario, Canada M5J 2N8 +1 (416) 849-8900