Vba 在字典中存储数据的递归函数

我有一个递归函数，它接收三个参数（文件夹路径、递归搜索开关和作为变量/数组的文件类型列表），输出是搜索文件夹中所有文件路径的字典（图片中的示例文件夹）

其思想是使用一个shell“应用程序对象”，然后测试属于该“文件夹项目对象”的所有项目（文件或文件夹），如果它们满足某个文件类型，则会添加到字典中 如果要测试的对象是文件夹，那么它将通过处理。在这段代码中，我使用了“GoTo”关键字来进行文件夹处理，而不从函数本身调用该函数，因为我尝试从函数本身调用该函数，每次调用该函数时都会创建一个新的字典，并替换旧的字典值

问题是：

如何递归调用函数以避免在不使用GoTo关键字和不在函数外定义另一个字典的情况下创建新字典的问题

此外，任何改进现行准则的想法都将受到欢迎

这是代码

Sub test()

    Dim fpath As String
    fpath = "C:\TestFolder"

    Dim arrFileTypes() As Variant
    arrFileTypes = Array(".docx", ".doc", ".rtf", ".txt")

    'let's test if the function works
    Call ListItemsInFolder2(fpath, True, arrFileTypes)

End Sub


Function ListItemsInFolder2(FolderPath As String, LookInSubFolders As Boolean, ByRef SearchedFileTypes As Variant)
        Dim PathsDict As Object
        Set PathsDict = CreateObject("Scripting.Dictionary")

        Dim ShellAppObject As Object
        Dim objFolder As Object
        Dim fldItem As Object
        Dim i As Long
        Dim k As Long
        k = 0

    ShellNewObj:
        'check if there is already shell objs from previous searches and set them to nothing
        If (Not ShellAppObject Is Nothing) Then
            Set ShellAppObject = Nothing
            FolderPath = fldItem.Path
        End If

        If (Not objFolder Is Nothing) Then
            Set objFolder = Nothing
        End If

        Set ShellAppObject = CreateObject("Shell.Application")
        Set objFolder = ShellAppObject.Namespace("" & FolderPath)
        'k = 0

        For Each fldItem In objFolder.Items

            If InStr(1, fldItem.Parent, ".zip", vbTextCompare) = 0 Then    'vbTextCompare ==> negelct case sensitivity of file extension
                'its not a zip file
                If (fldItem.IsFolder) Then    'check if the current item is a folder
                    'the item is a folder
                Else    'the item is a file

                    For i = LBound(SearchedFileTypes) To UBound(SearchedFileTypes)
                        'check if the file extension ex(.doc) matches the input from array
                        If Mid(fldItem.Name, InStrRev(fldItem.Name, ".", , vbTextCompare)) = LCase(SearchedFileTypes(i)) Then
                            PathsDict.Add Key:=k, Item:=fldItem.Path    'add those files to the dictionary
                            k = k + 1
                        End If
                    Next i

                End If
                If (fldItem.IsFolder And LookInSubFolders) Then
                    GoTo ShellNewObj:

                    '*** here is the old line of code ***
                    'ListItemsInFolder fldItem.Path, LookInSubFolders, SearchedFileTypes
                    '***

                End If
            Else  'its a zip file
                'do nothing and bypass it
            End If
        Next fldItem

        ListItemsInFolder2 = PathsDict.Items
        Set ShellAppObject = Nothing
        Set PathsDict = Nothing
    End Function

---

要获取与Scripting.FileSystemObject的一个或多个扩展名匹配的所有文件，请执行以下操作：

Sub UsageExample()
  Dim files()
  files = FindFiles("C:\temp", True, "*.docx", "*.txt")

  Debug.Print Join(files, vbCrLf)
End Sub

''
' Function to search all the files matching on or more pattern
' @folder {String} Initial folder
' @subfolders {Boolean} If true the function will search in the sub folders
' @patterns {Array} List of patterns to search. Ex: "*.txt"
' Returns an array of full paths
''
Public Function FindFiles(folder As String, subfolders As Boolean, ParamArray patterns())
  Dim results$(), count&, fso As Object
  ReDim results(0 To 255)
  Set fso = CreateObject("Scripting.FileSystemObject")

  FindFilesRecursive results, count, fso.GetFolder(folder), Array(patterns)(0), subfolders

  ' resize and return the results
  If count Then
    ReDim Preserve results(0 To count - 1)
    FindFiles = results
  End If
End Function

Private Sub FindFilesRecursive(results$(), count&, folder As Object, patterns, recursive As Boolean)
  Dim item As Object, name$

  ' handle each file
  For Each item In folder.files
    name = item.name
    For Each pattern In patterns
      If name Like pattern Then
        If count > UBound(results) Then ReDim Preserve results(0 To UBound(results) * 2)
        results(count) = item.path
        count = count + 1
      End If
    Next
  Next

  ' handle each folder
  If recursive Then
    For Each item In folder.subfolders
      FindFilesRecursive results, count, item, patterns, recursive
    Next
  End If
End Sub

---

要获取与Dir匹配的一个或多个扩展名的所有文件，请执行以下操作：

''
' Function to search all the files matching on or more pattern
' @folder {String} Initial folder
' @subfolders {Boolean} If true the function will search in the sub folders
' @patterns {Array} List of patterns to search. Ex: "*.txt"
' Returns an array of full paths
''
Function FindFiles(ByVal folder$, subfolders As Boolean, ParamArray patterns())
  Dim fname$, dname$, i&, pattern, files$(), filesLen&, folders$(), foldersLen&

  If Right(folder, 1) <> "\" Then folder = folder & "\"
  ReDim files$(0 To 1024)
  ReDim folders$(0 To 1024)
  folders(0) = folder
  foldersLen = 1

  Do While i < foldersLen
    folder = folders(i)

    ' handle files
    fname = Dir(folder)
    Do While Len(fname)
        For Each pattern In patterns
          If fname Like pattern Then
            If filesLen > UBound(files) Then ReDim Preserve files(0 To UBound(files) * 2)
            files(filesLen) = folder & fname
            filesLen = filesLen + 1
          End If
        Next
        fname = Dir()
    Loop

    ' handle sub folders
    If subfolders Then
      dname = Dir(folder, vbDirectory)
      Do While Len(dname)
        If Asc(dname) <> 46 Then ' if doesn't start with "."
          If (GetAttr(folder & dname) And vbDirectory) <> 0 Then
            If foldersLen > UBound(folders) Then
              ReDim Preserve folders(0 To UBound(folders) * 2)
            End If
            folders(foldersLen) = folder & dname & "\"
            foldersLen = foldersLen + 1
          End If
        End If
        dname = Dir()
      Loop
    End If

    i = i + 1
  Loop

  ' resize and return the results
  If filesLen Then
    ReDim Preserve files(0 To filesLen - 1)
    FindFiles = files
  End If
End Function

---

谢谢你的帮助，你为什么不把这两个函数合并在一起呢？。另外，就性能而言，FSO和ArrayList Obj不如Shell Obj和字典。如果您可以使用shell对象编写代码，那就太好了。我尝试了你的代码，它可以在一个有1142个文件的文件夹上正常工作，但是需要2.7秒，这对我的项目来说是一个很长的时间。我还注意到，我上面的代码没有添加文件夹中的所有文件，您或任何人可以检查有什么问题吗？非常感谢，使用Dir（）只需5秒..您从哪里获得了30000个文件？：）。在检查是否为目录时，您没有考虑在

dname

中可能找到的Unicode字母和数字。我在检查一份包含印地语源代码的阿拉伯文件名列表时遇到了这一问题，其中印地语中的数字“٢”与阿拉伯语中的等效数字“2”进行了比较，并出现了一个错误，因为没有找到这样的文件。我会尽力解决那个问题的，请随时帮忙

FindFiles with FileSystemObject : 23078 ms
FindFiles with Dir()            :  5000 ms