Question

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

想法是使用shell“Application object”然后，测试属于该“文件夹项目对象”的所有项目（文件或文件夹），如果它们符合某种文件类型，则会将它们添加到字典中如果正在测试的对象是文件夹，那么它将被传递以进行处理。在这段代码中，我使用“GoTo”关键字进行文件夹处理，而不从内部调用Function，因为我尝试从内部调用函数，每次调用函数时都会创建一个新的字典并替换旧的字典值

问题是：

如何在不使用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

Answer 1

使用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

包含30000多个文件的文件夹的执行时间：

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

VBA递归函数，用于将数据存储在字典中

1 个答案: