Click here to Skip to main content
Rate this: bad
good
Please Sign up or sign in to vote.
See more: VBScript directory
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:
 

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 28-Mar-11 5:20am
Edited 28-Mar-11 22:36pm
v2
Rate this: bad
good
Please Sign up or sign in to vote.

Solution 1

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.)
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
  Permalink  
v2
Rate this: bad
good
Please Sign up or sign in to vote.

Solution 3

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
		'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:
 
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.
  Permalink  
Rate this: bad
good
Please Sign up or sign in to vote.

Solution 2

Thanks, Just what I was looking for
  Permalink  

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

  Print Answers RSS
0 OriginalGriff 7,903
1 Sergey Alexandrovich Kryukov 7,142
2 DamithSL 5,604
3 Manas Bhardwaj 4,986
4 Maciej Los 4,820


Advertise | Privacy | Mobile
Web03 | 2.8.1411023.1 | Last Updated 21 Apr 2012
Copyright © CodeProject, 1999-2014
All Rights Reserved. Terms of Service
Layout: fixed | fluid

CodeProject, 503-250 Ferrand Drive Toronto Ontario, M3C 3G8 Canada +1 416-849-8900 x 100