如何在excel vba动态数组中包含文件系统对象属性

Question

我正在尝试研究如何使用 filesystemobject 将文件和文件夹的创建日期、修改日期、大小、路径、文件/文件夹名称包含到 excel vba 动态数组中，以便它自动扩展或收缩到文件/文件夹。

此外，我正在尝试列出排除的文件夹路径，这样当我单击搜索时，只有那些文件夹路径及其文件会从结果列表中排除，但会显示其他文件夹及其文件。是否可以制作一个文件夹路径列表，排除更深的嵌套文件夹子文件夹？

例如，在这个文件夹中 C:\test with spaces\（见图）folder structure 我想排除 C:\test with spaces\subfolder 1\2ndlevelsubfolder1\ 中的文件，包括“2ndlevelsubfolder1”，但我想要要显示的所有其他文件夹路径。如何使用 vba 做到这一点？

最后，我还想让这个列表递归，这样每次我添加/删除排除的文件夹路径列表时，都会在前一个列表之后添加新条目。我在不同的 Excel 工作簿中创建了这些函数，但唯一的问题是将它们合并到一个代码中。我正在向您展示我来自 2 个工作簿的代码：

1. 此代码用于递归列表：

Option Explicit
Sub SomeSub()
    Call GetFiles("\\?\[INSERT PARENT FOLDER PATH HERE]") 'attach "\\?\" at the beginning for long folder path names! ex..'GetFiles("\\?\INSERT..."
    'can also list multiple "Call GetFiles("\\?\[insert new folder path here]")" to list multiple folder paths all at once
End Sub
Sub GetFiles(ByVal path As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")

Dim folder As Object
Set folder = FSO.GetFolder(path)

Dim SubFolder As Object
Dim file As Object

For Each SubFolder In folder.Subfolders
    GetFiles (SubFolder.path)
Next SubFolder

Range("A1") = "parent folder"
'Range("A1").Offset(0, 1) = "FILE/FOLDER PATH"
Range("A1").Offset(0, 3) = "FILE or FOLDER"
Range("A1").Offset(0, 4) = "DATE CREATED"
Range("A1").Offset(0, 5) = "DATE MODIFIED"
Range("A1").Offset(0, 6) = "SIZE"
Range("A1").Offset(0, 7) = "TYPE"
    
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(folder, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = folder.Name
    Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FOLDER"
    Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = folder.datecreated
    Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = folder.DateLastModified

For Each SubFolder In folder.Subfolders
    'Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(subfolder.path, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = subfolder.Name
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FOLDER"
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = subfolder.datecreated
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = subfolder.DateLastModified
Next SubFolder

For Each file In folder.Files
    Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = Replace(file.path, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = Replace(folder, "\\?\", "")
    'Range("A" & Rows.Count).End(xlUp).Offset(0, 2) = file.Name
    Range("A" & Rows.Count).End(xlUp).Offset(0, 3) = "FILE"
    Range("A" & Rows.Count).End(xlUp).Offset(0, 4) = file.datecreated
    Range("A" & Rows.Count).End(xlUp).Offset(0, 5) = file.DateLastModified
    Range("A" & Rows.Count).End(xlUp).Offset(0, 6) = file.Size
    Range("A" & Rows.Count).End(xlUp).Offset(0, 7) = file.Type
Next file

With Range("E:F")
.NumberFormat = "dddd mmmm dd, yyyy H:mm:ss AM/PM" 'long file date and time
End With

Set FSO = Nothing
Set folder = Nothing
Set SubFolder = Nothing
Set file = Nothing

End Sub

1. 这是单元格 A3 中排除的文件夹名称列表代码，仅将名称插入单元格 A3，以逗号分隔，逗号后没有空格。我希望排除任何子文件夹级别的文件夹路径，而不仅仅是第一级的名称

Option Explicit
'http://www.ozgrid.com/forum/showthread.php?t=158478
Dim iRow As Long

Sub ListFiles()
    Dim lRow As Long
    iRow = 11
    lRow = Range("B" & Rows.Count).End(xlUp).Row
    If lRow >= iRow Then
      Range("B" & iRow & ":E" & Range("B" & Rows.Count).End(xlUp).Row).Clear
    End If
    Call ListMyFiles(Range("A1"), Range("A2"), Range("A3")) 'Cell A1 is the parent directory, A2 is include subfolders as false or true _
                                                                cell A3 is the exclude folder names within the parent directory _
                                                                which only works in the 1st level not deeper nested levels
    Application.GoTo Range("B3"), True
End Sub

Sub ListMyFiles(mySourcePath As String, IncludeSubfolders As String, _
  Optional excludedSubfolders As String = " ")
    Dim myObject As Scripting.FileSystemObject
    Dim mySource As Scripting.folder, myFile As Variant
    Dim myfolder As Variant
    Dim iCol As Integer
    Dim mySubFolder As Scripting.folder, v As Variant
    Dim asf() As String, sf As String
    
    asf() = Split(Replace(excludedSubfolders, ", ", ","), ",")
    
    Set myObject = New Scripting.FileSystemObject
    If Right(mySourcePath, 1) <> "\" Then mySourcePath = mySourcePath + "\"
    Set mySource = myObject.GetFolder(mySourcePath)
    On Error Resume Next
      
    For Each mySubFolder In mySource.SubFolders
        iCol = 1
        Cells(iRow, iCol).Value = mySubFolder.Path
        iCol = iCol + 1
        Cells(iRow, iCol).Value = mySubFolder.Name
        iRow = iRow + 1
    Next mySubFolder
    
    If IncludeSubfolders Then
        For Each mySubFolder In mySource.SubFolders
            If excludedSubfolders = " " Then
              Call ListMyFiles(mySubFolder.Path, True)
              Else
              sf = Trim(Right(mySubFolder.Path, Len(mySubFolder.Path) - Len(mySourcePath)))
              If IndexStrArray(asf(), sf) = -1 Then Call ListMyFiles(mySubFolder.Path, True)
            End If
            Next
            End If
End Sub

'val is not case sensitive
Function IndexStrArray(vArray() As String, sVal As String) As Long
  Dim v As Variant, i As Long
  On Error GoTo Minus1
  For i = 0 To UBound(vArray)
    If LCase(vArray(i)) = LCase(sVal) Then
      IndexStrArray = i
      Exit Function
    End If
  Next i
Minus1:
  IndexStrArray = -1
End Function

我希望这对我想要实现的目标有所启发。谢谢您，希望尽快收到您的来信。

Answer 1

不确定它会 100% 满足您的需求。 您应该像这样使用集合和递归子（未完全测试，可能需要一些更正）：

' List of complete path of files in folder / subfolders
' Needs to add "Microsoft Scripting Runtime" reference to your file
Sub FolderFilesPath(ByVal pFolder As String, ByRef pColFiles As Collection, _
    Optional ByVal pGetSubFolders As Boolean, Optional ByVal pFilter As Collection)
    Dim sFolder As String
    Dim oFSO As New FileSystemObject
    Dim oFolder, oSubFolder As Folder
    Dim oFile As File
    
    sFolder = IIf(Right(pFolder, 1) <> "\", pFolder & "\", pFolder)
    Set oFolder = oFSO.GetFolder(sFolder)
    If Not ExistsInCollection(pFilter, oFolder) Then
        For Each oFile In oFolder.Files
            pColFiles.Add oFile
        Next oFile
        If pGetSubFolders Then
            For Each oSubFolder In oFolder.SubFolders
                FolderFilesPath oSubFolder.Path, pColFiles, pGetSubFolders, 
pFilter
            Next
        End If
    End If
End Sub

' Vba collection contains
Function ExistsInCollection(col As Collection, key As Variant) As Boolean
    On Error GoTo err
    ExistsInCollection = True
    IsObject (col.Item(key))
    Exit Function
err:
    ExistsInCollection = False
End Function
'------------------------------------------------------------------------------
Sub TestMe()
    Dim colFiles As New Collection, sFilePath As Variant
    Dim colExcludedFolders As New Collection
    With colExcludedFolders
        .Add "C:\test with spaces\subfolder 1\"
    End With
    FolderFilesPath ThisWorkbook.Path, colFiles, True, colExcludedFolders
    ' colFiles contains filtered files
    For Each sFilePath In colFiles
        With sFilePath
            Debug.Print .Path & " - " & .Name & " - " & .DateCreated
        End With
    Next sFilePath
End Sub

Answer 2

现在我收到运行时错误“28”：堆栈空间不足

这段代码有什么问题？