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

Question

我正试图找出如何使用filesystemobject包括日期创建，日期修改，大小，路径，文件和文件夹的文件/文件夹名称到excel vba动态数组，使其自动扩展或收缩到文件/文件夹列表。

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

例如，在这个文件夹C:test with spaces(见图)文件夹结构中，我想排除C:test with spacessubfolder 12ndlevelsubfolder1包括"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

2. 这是单元格A3中被排除的文件夹名称列表代码，只有名称被插入单元格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 spacessubfolder 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':Out of stack space

这段代码有什么问题?