获取VBA中的子目录列表 我想得到一个目录中所有子目录的列表 如果可以的话,我想把它扩展成一个递归函数
然而,我最初获取细分曲面的方法失败了。它只显示所有内容,包括文件:获取VBA中的子目录列表 我想得到一个目录中所有子目录的列表 如果可以的话,我想把它扩展成一个递归函数,vba,recursion,ms-office,ms-word,Vba,Recursion,Ms Office,Ms Word,然而,我最初获取细分曲面的方法失败了。它只显示所有内容,包括文件: sDir = Dir(sPath, vbDirectory) Do Until LenB(sDir) = 0 Debug.Print sDir sDir = Dir Loop 该列表以“..”和几个文件夹开头,以“.txt”文件结尾 编辑: 我应该补充一点,这必须在Word中运行,而不是Excel(Word中没有许多功能),而且是Office 2010 编辑2: 可以使用以下方法确定结果的类型: iAtt
sDir = Dir(sPath, vbDirectory)
Do Until LenB(sDir) = 0
Debug.Print sDir
sDir = Dir
Loop
该列表以“..”和几个文件夹开头,以“.txt”文件结尾
编辑:
我应该补充一点,这必须在Word中运行,而不是Excel(Word中没有许多功能),而且是Office 2010
编辑2: 可以使用以下方法确定结果的类型:
iAtt = GetAttr(sPath & sDir)
If CBool(iAtt And vbDirectory) Then
...
End If
但这给了我新的问题,因此我现在使用的代码基于
脚本。FileSystemObject
您最好使用FileSystemObject。我想
你只需要说:
listfolders“c:\data”
2014年7月更新:添加了PowerShell
选项,并将第二个代码缩减为仅列出文件夹
下面的方法运行一个完整的递归过程来代替Office2007中不推荐使用的FileSearch
。(后两个代码仅将Excel用于输出-在Word中运行时可以删除此输出)
PowerShell
FSO
和Dir
筛选文件类型。源于此,位于EE付费墙后面。这比您要求的(文件夹列表)要长,但我认为它很有用,因为它可以为您提供一系列的结果以供进一步处理Dir
。这个例子来自我在另一个网站上提供的答案PowerShell
将C:\temp下面的所有文件夹转储到csv文件中
Sub Comesfast()
X2 = Shell("powershell.exe Get-ChildItem c:\temp -Recurse | ?{ $_.PSIsContainer } | export-csv C:\temp\filename.csv", 1)
End Sub
2。使用FileScriptingObject
将C:\temp下面的所有文件夹转储到Excel中
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim strPath As String
strPath = "c:\temp\"
myArr = GetSubFolders(strPath)
[A1].Resize(UBound(myArr, 1), 1) = Application.Transpose(myArr)
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
Counter = Counter + 1
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
3使用Dir
Option Explicit
Public StrArray()
Public lngCnt As Long
Public b_OS_XP As Boolean
Public Enum MP3Tags
' See http://www.kixtart.org/forums/ubbthreads.php?ubb=showflat&Number=160880&page=1 for OS specific attribute lists
XP_Artist = 16
XP_AlbumTitle = 17
XP_SongTitle = 10
XP_TrackNumber = 19
XP_RecordingYear = 18
XP_Genre = 20
XP_Duration = 21
XP_BitRate = 22
Vista_W7_Artist = 13
Vista_W7_AlbumTitle = 14
Vista_W7_SongTitle = 21
Vista_W7_TrackNumber = 26
Vista_W7_RecordingYear = 15
Vista_W7_Genre = 16
Vista_W7_Duration = 17
Vista_W7_BitRate = 28
End Enum
Public Sub Main()
Dim objws
Dim objWMIService
Dim colOperatingSystems
Dim objOperatingSystem
Dim objFSO
Dim objFolder
Dim Wb As Workbook
Dim ws As Worksheet
Dim strobjFolderPath As String
Dim strOS As String
Dim strMyDoc As String
Dim strComputer As String
'Setup Application for the user
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
'reset public variables
lngCnt = 0
ReDim StrArray(1 To 10, 1 To 1000)
' Use wscript to automatically locate the My Documents directory
Set objws = CreateObject("wscript.shell")
strMyDoc = objws.SpecialFolders("MyDocuments")
strComputer = "."
Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem In colOperatingSystems
strOS = objOperatingSystem.Caption
Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
If InStr(strOS, "XP") Then
b_OS_XP = True
Else
b_OS_XP = False
End If
' Format output sheet
Set Wb = Workbooks.Add(1)
Set ws = Wb.Worksheets(1)
ws.[a1] = Now()
ws.[a2] = strOS
ws.[a3] = strMyDoc
ws.[a1:a3].HorizontalAlignment = xlLeft
ws.[A4:J4].Value = Array("Folder", "File", "Artist", "Album Title", "Song Title", "Track Number", "Recording Year", "Genre", "Duration", "Bit Rate")
ws.Range([a1], [j4]).Font.Bold = True
ws.Rows(5).Select
ActiveWindow.FreezePanes = True
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strMyDoc)
' Start the code to gather the files
ShowSubFolders objFolder, True
ShowSubFolders objFolder, False
If lngCnt > 0 Then
' Finalise output
With ws.Range(ws.[a5], ws.Cells(5 + lngCnt - 1, 10))
.Value2 = Application.Transpose(StrArray)
.Offset(-1, 0).Resize(Rows.Count - 3, 10).AutoFilter
.Offset(-4, 0).Resize(Rows.Count, 10).Columns.AutoFit
End With
ws.[a1].Activate
Else
MsgBox "No files found!", vbCritical
Wb.Close False
End If
' tidy up
Set objFSO = Nothing
Set objws = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
.StatusBar = vbNullString
End With
End Sub
Sub ShowSubFolders(ByVal objFolder, bRootFolder As Boolean)
Dim objShell
Dim objShellFolder
Dim objShellFolderItem
Dim colFolders
Dim objSubfolder
'strName must be a variant, as ParseName does not work with a string argument
Dim strFname
Set objShell = CreateObject("Shell.Application")
Set colFolders = objFolder.SubFolders
Application.StatusBar = "Processing " & objFolder.Path
If bRootFolder Then
Set objSubfolder = objFolder
GoTo OneTimeRoot
End If
For Each objSubfolder In colFolders
'check to see if root directory files are to be processed
OneTimeRoot:
strFname = Dir(objSubfolder.Path & "\*.mp3")
Set objShellFolder = objShell.Namespace(objSubfolder.Path)
Do While Len(strFname) > 0
lngCnt = lngCnt + 1
If lngCnt Mod 1000 = 0 Then ReDim Preserve StrArray(1 To 10, 1 To (lngCnt + 1000))
Set objShellFolderItem = objShellFolder.ParseName(strFname)
StrArray(1, lngCnt) = objSubfolder
StrArray(2, lngCnt) = strFname
If b_OS_XP Then
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.XP_BitRate)
Else
StrArray(3, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Artist)
StrArray(4, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_AlbumTitle)
StrArray(5, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_SongTitle)
StrArray(6, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_TrackNumber)
StrArray(7, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_RecordingYear)
StrArray(8, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Genre)
StrArray(9, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_Duration)
StrArray(10, lngCnt) = objShellFolder.GetDetailsOf(objShellFolderItem, MP3Tags.Vista_W7_BitRate)
End If
strFname = Dir
Loop
If bRootFolder Then
bRootFolder = False
Exit Sub
End If
ShowSubFolders objSubfolder, False
Next
End Sub
这是一个不使用
脚本的简单版本。FileSystemObject
,因为我发现它速度慢且不可靠。尤其是.Name
方法,使一切都变慢了。我还在Excel中测试了这个,但我不认为我使用的任何东西在Word中都不可用
首先是一些功能:
这将连接两个字符串以创建文件路径,类似于python中的os.path.join
。如果您在路径的末尾附加了“\”,则无需记住这一点非常有用
Const sep as String = "\"
Function pjoin(root_path As String, file_path As String) As String
If right(root_path, 1) = sep Then
pjoin = root_path & file_path
Else
pjoin = root_path & sep & file_path
End If
End Function
这将创建根目录的子项集合root\u路径
Function subItems(root_path As String, Optional pat As String = "*", _
Optional vbtype As Integer = vbNormal) As Collection
Set subItems = New Collection
Dim sub_item As String
sub_item= Dir(pjoin(root_path, pat), vbtype)
While sub_item <> ""
subItems.Add (pjoin(root_path, sub_item))
sub_item = Dir()
Wend
End Function
最后是一个递归搜索函数,该函数基于此站点中使用脚本编写的其他函数。FileSystemObject我还没有对它和原始函数进行任何比较测试。如果我再找到那篇文章,我会把它链接起来。注意collec
是通过引用传递的,因此创建一个新集合并调用此子集合来填充它。传递所有子文件夹的vbType:=vbDirectory
Sub walk(root_path As String, ByRef collec as Collection, Optional pat As String = "*" _
Optional vbType as Integer = vbNormal)
Dim subF as Collection
Dim subD as Collection
Set subF = subItems(root_path, pat, vbType)
For Each sub_file In subF
collec.Add sub_file
Next sub_file
Set subD = subFolders(root_path)
For Each sub_folder In subD
walk sub_folder , collec, pat, vbType
Next sub_folder
End Sub
这是一个VBA解决方案,不使用外部对象 由于
Dir()
函数的限制,您需要一次获取每个文件夹的全部内容,而不是在使用递归算法爬行时获取
Function GetFilesIn(Folder As String) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add F
F = Dir
Loop
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
F = Dir
Loop
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
End Sub
函数GetFilesIn(文件夹作为字符串)作为集合
作为字符串的Dim F
Set GetFilesIn=新集合
F=Dir(文件夹&“\*”)
在F“”时执行
GetFilesIn.addf
F=Dir
环
端函数
函数GetFoldersIn(文件夹作为字符串)作为集合
作为字符串的Dim F
Set GetFoldersIn=新集合
F=Dir(文件夹&“\*”,vbDirectory)
在F“”时执行
如果是GetAttr(Folder&“\”&F)和vbDirectory,那么是GetFoldersIn.Add F
F=Dir
环
端函数
子测试()
尺寸C作为集合,F
调试。打印
调试.打印“C:\”中的文件
设置C=GetFilesIn(“C:\”)
对于C中的每个F
调试。打印F
下一个F
调试。打印
调试.打印“C:\”中的文件夹
设置C=GetFoldersIn(“C:\”)
对于C中的每个F
调试。打印F
下一个F
端接头
编辑
此版本深入子文件夹并返回完整路径名,而不是仅返回文件或文件夹名
不要在整个C驱动器上运行测试
Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add JoinPaths(Folder, F)
F = Dir
Loop
If Recursive Then
Dim SubFolder, SubFile
For Each SubFolder In GetFoldersIn(Folder)
If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then
For Each SubFile In GetFilesIn(CStr(SubFolder), True)
GetFilesIn.Add SubFile
Next SubFile
End If
Next SubFolder
End If
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F)
F = Dir
Loop
End Function
Function JoinPaths(Path1 As String, Path2 As String) As String
JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\")
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "All files in C:\"
Set C = GetFilesIn("C:\", True)
For Each F In C
Debug.Print F
Next F
End Sub
函数GetFilesIn(文件夹为字符串,可选递归为布尔值=False)作为集合
作为字符串的Dim F
Set GetFilesIn=新集合
F=Dir(文件夹&“\*”)
在F“”时执行
添加连接路径(文件夹,F)
F=Dir
环
如果是递归的,那么
变暗子文件夹,子文件
对于GetFoldersIn(文件夹)中的每个子文件夹
如果右(子文件夹,2)“\”和右(子文件夹,3)“\..”则
对于GetFilesIn(CStr(子文件夹)中的每个子文件,True)
GetFilesIn.Add子文件
下一个子文件
如果结束
下一个子文件夹
如果结束
端函数
函数GetFoldersIn(文件夹作为字符串)作为集合
作为字符串的Dim F
Set GetFoldersIn=新集合
F=Dir(文件夹&“\*”,vbDirectory)
在F“”时执行
如果是GetAttr(文件夹&“\”&F)和vbDirectory,则是GetFoldersIn.addjoinpath(文件夹,F)
F=Dir
环
端函数
函数joinPath(路径1作为字符串,路径2作为字符串)作为字符串
JoinPaths=Replace(路径1&“\”&Path2,“\”,“\”)
端函数
子测试()
尺寸C作为集合,F
调试。打印
调试.打印“C:\”中的文件
设置C=GetFilesIn(“C:\”)
对于C中的每个F
调试。打印F
下一个F
调试。打印
调试.打印“C:\”中的文件夹
设置C=GetFoldersIn(“C:\”)
对于C中的每个F
调试。打印F
下一个F
调试。打印
调试。打印“C中的所有文件:\”
设置C=GetFilesIn(“C:\”,True)
对于C中的每个F
调试。打印F
下一个F
端接头
我认为问题的目的是在满足查找第一级子文件夹的初始问题后查找所有子目录,即“如果可行,我想将其扩展为递归函数”@brettdj这不是我阅读的方式。如果找到目录,我将其解读为“如果代码有效”而不是“不”“。在任何一种情况下,FileSystemObject查找目录的事实都会有所帮助,毕竟,递归行可以很容易地注释掉,然后注释掉所有一级目录w
Function GetFilesIn(Folder As String) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add F
F = Dir
Loop
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add F
F = Dir
Loop
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
End Sub
Function GetFilesIn(Folder As String, Optional Recursive As Boolean = False) As Collection
Dim F As String
Set GetFilesIn = New Collection
F = Dir(Folder & "\*")
Do While F <> ""
GetFilesIn.Add JoinPaths(Folder, F)
F = Dir
Loop
If Recursive Then
Dim SubFolder, SubFile
For Each SubFolder In GetFoldersIn(Folder)
If Right(SubFolder, 2) <> "\." And Right(SubFolder, 3) <> "\.." Then
For Each SubFile In GetFilesIn(CStr(SubFolder), True)
GetFilesIn.Add SubFile
Next SubFile
End If
Next SubFolder
End If
End Function
Function GetFoldersIn(Folder As String) As Collection
Dim F As String
Set GetFoldersIn = New Collection
F = Dir(Folder & "\*", vbDirectory)
Do While F <> ""
If GetAttr(Folder & "\" & F) And vbDirectory Then GetFoldersIn.Add JoinPaths(Folder, F)
F = Dir
Loop
End Function
Function JoinPaths(Path1 As String, Path2 As String) As String
JoinPaths = Replace(Path1 & "\" & Path2, "\\", "\")
End Function
Sub Test()
Dim C As Collection, F
Debug.Print
Debug.Print "Files in C:\"
Set C = GetFilesIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "Folders in C:\"
Set C = GetFoldersIn("C:\")
For Each F In C
Debug.Print F
Next F
Debug.Print
Debug.Print "All files in C:\"
Set C = GetFilesIn("C:\", True)
For Each F In C
Debug.Print F
Next F
End Sub