获得vba的子目录
- 我想获得一个文件夹中所有子目录的列表。
- 如果这个工作，我想扩大到recursionfunction。
然而，我最初的方法来获得subdirs失败。 它只是显示一切包括文件：
sDir = Dir(sPath, vbDirectory) Do Until LenB(sDir) = 0 Debug.Print sDir sDir = Dir Loop 该列表以“..”和多个文件夹开头，以“.txt”文件结尾。
编辑：我应该补充说，这必须在Word中运行，而不是Excel（许多function在Word中不可用），它是Office 2010。
编辑2：
可以确定使用结果的types
iAtt = GetAttr(sPath & sDir) If CBool(iAtt And vbDirectory) Then ... End If
但是这给了我新的问题，所以我现在正在使用基于Scripting.FileSystemObject的代码。
2014年7月更新：添加PowerShell选项，并削减第二个代码只列出文件夹
下面的方法运行一个完整的recursion过程来代替在Office 2007中弃用的FileSearch 。 （后面的两个代码使用Excel仅用于输出 – 此输出可以在Word中运行时删除）
- Shell
PowerShell - 使用
FSO和Dir来过滤文件types。 来源于EE薪酬背后的EE 回答 。 这比你所要求的（文件夹列表）要长，但我认为它很有用，因为它可以让你得到一系列结果， - 使用
Dir。 这个例子来自我在另一个网站上提供的答案
1.使用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会更好。 我认为。
要调用这个，你只需要说：listfolders“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
这里是一个简单的版本没有使用Scripting.FileSystemObject因为我发现它很慢，不可靠。 特别是.Name方法，正在放缓一切。 此外，我在Excel中testing了这一点，但我不认为我使用的任何东西都不会在Word中可用。
首先是一些function：
这join了两个string来创build一个文件path，类似于python中的os.path.join 。 不需要记住是否在path末尾添加了“\”。
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
这将创build根目录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中创build包含文件夹的子项目集合，然后从集合中删除不是文件夹的项目。 它可以select删除那些讨厌. 和..文件夹
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基于本站的别人function的recursionsearchfunction，我还没有做过任何与原来的比较testing。 如果我再次find这个post，我会链接它。 注意collec是通过引用传递的，所以创build一个新的集合并调用这个子集来填充它。 通过所有子文件夹的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解决scheme，不使用外部对象。
由于Dir()函数的限制，您需要一次获取每个文件夹的全部内容，而不是使用recursionalgorithm进行爬网。
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
编辑
此版本挖掘到子文件夹并返回完整的path名称，而不是仅返回文件或文件夹名称。
不要在整个C盘上运行testing！
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
