但是我最初获取子目录的方法失败了。它只是显示包括文件在内的所有内容:
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
但这给了我新的问题,所以我现在使用基于
Scripting.FileSystemObject
的代码。
2014 年 7 月更新:添加了
PowerShell
选项并削减第二个代码以仅列出文件夹
下面的方法运行完整的递归过程,代替在 Office 2007 中已弃用的
FileSearch
。(后面的两个代码仅使用 Excel 进行输出 - 在 Word 中运行时可以删除此输出)
PowerShell
FSO
和 Dir
来过滤文件类型。源自 EE 付费专区后面的EE 答案。这比您要求的(文件夹列表)要长,但我认为它很有用,因为它为您提供了一系列结果以供进一步使用Dir
。这个例子来自我在另一个网站上提供的答案1。使用
PowerShell
将 C: emp 下面的所有文件夹转储到 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: emp 下面的所有文件夹转储到 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 会更好。我估计。
要调用此功能,您只需说: 列表文件夹“c:\data”
Sub listfolders(startfolder)
''Reference Windows Script Host Object Model
''If you prefer, just Dim everything as Object
''and use CreateObject("Scripting.FileSystemObject")
Dim fs As New FileSystemObject
Dim fl1 As Folder
Dim fl2 As Folder
Set fl1 = fs.GetFolder(startfolder)
For Each fl2 In fl1.SubFolders
Debug.Print fl2.Path
listfolders fl2.Path
Next
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
编辑
此版本深入子文件夹并返回完整路径名,而不是仅返回文件或文件夹名称。
请勿在整个 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
这是一个没有使用
Scripting.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_path
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
这会在目录
root_path
中创建包含文件夹的子项目集合,然后从集合中删除不是文件夹的项目。它可以选择删除那些讨厌的 .
和 ..
文件夹
Function subFolders(root_path As String, Optional pat As String = "", _
Optional skipDots As Boolean = True) As Collection
Set subFolders = subItems(root_path, pat, vbDirectory)
If skipDots Then
Dim dot As String
Dim dotdot As String
dot = pjoin(root_path, ".")
dotdot = dot & "."
Do While subFolders.Item(1) = dot _
Or subFolders.Item(1) = dotdot
subFolders.remove (1)
If subFolders.Count = 0 Then Exit Do
Loop
End If
For i = subFolders.Count To 1 Step -1
' This comparison could be replaced by and `fileExists` function
If Dir(subFolders.Item(i), vbNormal) <> "" Then
subFolders.remove (i)
End If
Next i
End Function
最后是基于此站点上其他人使用的功能的递归搜索功能,使用
Scripting.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
迟到的回答,但为可能有类似问题的其他人发布。
我遇到了类似的挑战,但受到无法使用
FileSystemObject
的限制。因此,我编写了一个类库,它大量使用 Dir() 函数来解析指定目录中的所有文件和文件夹。它要求您在 VBA IDE 中不设置对其他库的引用。虽然我是为 Excel 编写的,但我测试并验证了它也可以在 Word 中运行。
您可以使用它来打印所有文件夹的列表,如下所示:
Sub PrintFilesAndFolders(Directory As DirectoryManager, Optional indent As String)
'Helper method
Dim folder As DirectoryManager
Dim newIndent As String
For Each folder In Directory.Folders
Debug.Print indent & "+ " & folder.Name
newIndent = indent & " "
PrintFilesAndFolders folder, newIndent
Next folder
End Sub
Sub LoopThroughAllFilesAndFolders()
Dim dm As DirectoryManager
Set dm = New DirectoryManager
dm.Path = ThisDocument.Path & "\Sample Data Set"
PrintFilesAndFolders dm
End Sub
示例文档显示了如何修改该脚本以包含文件(如果您愿意)。
这个纯基本代码对我有用,使用 Dir() 和一个数组作为子目录路径。
这避免了使用像 Collection 这样的 VBA 对象。
'
' get direct subdirectory full paths under the given directory
'
' uses:
' Dir(),GetAttr()
' inputs:
' strDir: directory
' arrPaths: array of found entry paths
' outputs:
' arrPaths: array of found entry paths
'
Function GetDirectSubDirs(ByVal strDir As String, ByRef arrPaths()) As Long
'
Dim i As Long, lEntry As Long
Dim str1 As String
'
i = 0
lEntry = 0
'
Do While (True)
'
If (lEntry = 0) Then
str1 = Dir(strDir & "\" & "*", vbDirectory)
Else
str1 = Dir()
End If
'
' have no more entries:
'
If (str1 = "") Then
Exit Do
'
' ignore current or parent directory:
'
ElseIf ((str1 = ".") Or (str1 = "..")) Then
'
' otherwise:
'
Else
'
' get full path:
'
str1 = strDir & "\" & str1
'
' save it if directory:
'
If (GetAttr(str1) And vbDirectory) Then
ReDim Preserve arrPaths(i)
arrPaths(i) = str1
i = i + 1
End If
End If
'
' count entries:
'
lEntry = lEntry + 1
'
Loop
'
GetDirectSubDirs = i
End Function
'
' get recursively subdirectory full paths
'
' uses:
' DoEvents(),UBound()
'
' GetDirectSubDirs(),
' GetSubDirsR()
' inputs:
' strDir: directory
' arrPaths: array of found entry paths
' outputs:
' arrPaths: array of found entry paths
'
Function GetSubDirsR(ByVal strDir As String, ByRef arrPaths()) As Long
'
Dim i As Long, iup As Long, iupFound As Long
Dim arrSubDirs()
'
On Error Resume Next
iupFound = UBound(arrPaths)
If (Err.Number 0) Then
iupFound = -1
Err = 0
End If
'
On Error GoTo 0
'
' handle subdirectories:
'
iup = GetDirectSubDirs(strDir, arrSubDirs) - 1
For i = 0 To iup
'
' this makes our code more interactive:
'
DoEvents
'
iupFound = iupFound + 1
ReDim Preserve arrPaths(iupFound)
'
arrPaths(iupFound) = arrSubDirs(i)
'
iupFound = GetSubDirsR(arrPaths(iupFound), arrPaths) - 1
'
Next
GetSubDirsR = iupFound + 1
End Function
'
' just test it:
'
Sub Test()
'
Dim i As Long, nFound As Long
Dim strDir As String
Dim arrPaths()
'
strDir = "C:\temp"
nFound = GetSubDirsR(strDir, arrPaths)
'
For i = 0 To nFound - 1
Debug.Print arrPaths(i)
Next
'
End Sub