指定文件夹下子文件夹遍历的工具

需求： 指定一个文件夹，需要得到文件夹下第三层的子文件夹的路径。

下面的程序，可以通过level的参数，指定遍历到第几层目录，如果设定为0，则遍历所有子目录

程序有一定的共同性，而且可以扩展。现在没有时间，稍后在更新完整的版本

 

Private Sub Button1_Click()
 Dim dctDict As Scripting.Dictionary
 Dim varItem As Variant
 Dim strDirPath As String
 Dim cnt As Integer
 
 Dim level As Integer
 level = 3
 Set dctDict = CreateObject("scripting.dictionary")
 strDirPath = "D:/test/"
 Range(Cells(20, 1), Cells(20, 100)).Clear
 
 
  If GetFiles(strDirPath, dctDict, 3) Then
   For Each varItem In dctDict
     Cells(20 + cnt, 1) = cnt + 1
     Cells(20 + cnt, 2) = varItem
     cnt = cnt + 1
  Next
   End If
End Sub

Function GetFiles(strPath As String, dctDict As Scripting.Dictionary, level As Integer) As Boolean

Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File

Set fsoSysObj = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set fdrFolder = fsoSysObj.GetFolder(strPath)

If Err <> 0 Then
  GetFiles = False
  GoTo GetFiles_End
End If
On Error GoTo 0

If 1 >= level Then
    For Each fdrSubFolder In fdrFolder.SubFolders
       dctDict.Add fdrSubFolder.Path, fdrSubFolder.Path
    Next fdrSubFolder
End If

   If 1 < level Or 0 = level Then
      For Each fdrSubFolder In fdrFolder.SubFolders
          GetFiles fdrSubFolder.Path, dctDict, level - 1
      Next fdrSubFolder
    End If
 
    GetFiles = True
   
GetFiles_End: Exit Function
 
End Function 

 

注意，FileSystemObject和Dictionary对象，要引用scripting runtime 才能正常编译。

工程---》引用----》MICROSOFT   SCRIPTING   RUNTIME

（日本版）ツール＞参照設定＞microsoft scripting runtime

 

参考文章：http://d-tune.javaeye.com/blog/481337