VB脚本列出目录文件夹和子文件夹-以缩进的树形结构导出到excel [英] VB Script to list directory folders and subfolders - export to excel with indented tree structure

查看：131
本文介绍了VB脚本列出目录文件夹和子文件夹-以缩进的树形结构导出到excel的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我试图编写一个vb脚本来获取目录(和子文件夹)的文件夹结构，并将该结构输出到excel.我可以以列表形式进行操作，但希望在excel中缩进目录树，以便您可以看到文件夹层次结构.

到目前为止，这是我的代码:


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

推荐答案

希望这会有所帮助-我将把列的格式留给您.我只修改了几行-添加了
ShowSubFolders子菜单的"revcol"和"Top"变量可以从左到右对列进行重新排序. (还为外观添加了cols B-D的三个列宽设置.)
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


我知道这个线程是一岁，但我正在寻找类似的脚本.当找到您的目录时，它已经接近我想要的了，但是我对其进行了修改，使其能够处理任何深度的目录.

由于某种原因，我无法使文件最后正确打开，因此我只留下了该部分的注释，并创建了一个不同的消息框.我也不需要链接文件，因此已注释掉了，但是很容易添加回来.我更改了输出文件的名称和位置，但是您的位置仍然在在那里评论了.

最后一件事，我添加了一个检查以查看输出文件夹是否存在.这就是为什么我有3个变量的原因:outputFolder，outputFile和outputTotal. OutputTotal是连接到一个变量中的其他两个.

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.


谢谢，正是我想要的


这篇关于VB脚本列出目录文件夹和子文件夹-以缩进的树形结构导出到excel的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文
相关文章
其他开发语言最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆