VBA-打开和过滤文件夹

问题描述

我有以下代码，我可以遍历文件夹中的所有 .dwg 文件。

    Private Sub CommandButton1_Click()
'open file to extract
    Dim MyFolderext As String
    Dim MyFileext As String
    'ficheiro origem
    MyFolderext = "C:\Users\abc\test"
    MyFileext = Dir(MyFolderext & "\*.dwg")
    do while MyFileext <> ""
    Application.Documents.Open MyFolderext & "\" & MyFileext

'check sub if not enough inputs were placed on the user console
check

'unlock drawing layers
ThisDrawing.Layers("MC_BLOCO_INFO_AREAS").Lock = False
ThisDrawing.Layers("MC_BLOCO_TEXTOS_COMERCIAL").Lock = False
ThisDrawing.Layers("MC_BLOCO_TEXTOS_INV").Lock = False

'sub of the program
program


MyFileext = Dir
    Loop
    
'when finished
Msg@R_404_6277@ "Done!"

'sub to clean to console for next operation
clean

End Sub

虽然它适用于文件夹内的所有文件，但我无法使其适用于子文件夹，我仍然需要过滤其中的一些。 所以我要问的是：您能帮我更改代码以打开母文件夹“C:\Users\abc\test”中的所有文件夹，但跳过文件夹“ignore”吗？

编辑： 我想出了这个，但仍然无法正常工作：

Sub FileSearch(ByRef Folder As Object)
Dim MyFileext As String
Dim File As Object
Dim SubFolder As Object
MyFileext = Dir(MainFolder & "\*.dwg")
do while MyFileext <> ""
Application.Documents.Open MainFolder & "\" & MyFileext
For Each File In Folder.Files
        programa
Next File
Loop

For Each SubFolder In Folder.SubFolders
    If SubFolder.Name <> "extras" Then
        FileSearch SubFolder 'Recursion
    End If
Next SubFolder
End Sub

Private Sub CommandButton1_Click()
    check
        Dim MainFolder As Object
    Set MainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\abc\test")
    
    FileSearch MainFolder
    
Msg@R_404_6277@ "Done!"

clean

End Sub

解决方法

您需要使用 FileSystemObject 将文件夹和文件设置为对象，以确定它们是否有子文件夹并能够检查子文件夹是否符合您的条件。

以下是如何遍历文件夹的文件及其子文件夹及其文件的示例：

Sub test()
    Dim MainFolder As Object,File As Object,SubFolder As Object
    Set MainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\abc\test\")
    
    For Each File In MainFolder.Files
        'do stuff
    Next File
    For Each SubFolder In MainFolder.Subfolders
        'If SubFolder Meets Your Criteria Then
            For Each File In SubFolder.Files
                'do stuff
            Next File
        'End If
    Next SubFolder
    
End Sub

该示例仅在子文件夹中搜索一级深度。这是一个搜索所有内容的示例：

Sub test()
    Dim MainFolder As Object
    Set MainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\abc\test\")
    
    FileSearch MainFolder
    
End Sub

Sub FileSearch(ByRef Folder As Object)
    Dim File As Object,SubFolder As Object
    For Each File In Folder.Files
        'do stuff
    Next File
    For Each SubFolder In Folder.SubFolders
        FileSearch SubFolder 'Recursion
    Next SubFolder
End Sub

为了回应您的意见，这里是另一个示例，它是我对如何将我的建议实施到您的原始代码中的最佳猜测。

Const FileExt As String = ".dwg" 'Module-Level Constant

Private Sub CommandButton1_Click()
'open file to extract
    Dim MainFolder As Object
    Set MainFolder = CreateObject("Scripting.FileSystemObject").GetFolder("C:\Users\abc\test\")
    FileSearch MainFolder
    Clean 'is this a sub of yours?
End Sub

Sub FileSearch(ByRef Folder As Object)
    Dim File As Object,SubFolder As Object
    For Each File In Folder.Files
        If File.Name Like "*" & FileExt Then
            ProcessDwg File
        End If
    Next File
    For Each SubFolder In Folder.SubFolders
        If Not LCase(SubFolder.Name) Like "*ignore*" Then
            FileSearch SubFolder 'Recursion
        End If
    Next SubFolder
End Sub
Sub ProcessDwg(ByRef dwgFile As Object)
    Dim ThisDrawing As Object
    Set ThisDrawing = Application.Documents.Open(dwgFile.Path)
    check 'is this a sub of yours?
    ThisDrawing.Layers("MC_BLOCO_INFO_AREAS").Lock = False
    ThisDrawing.Layers("MC_BLOCO_TEXTOS_COMERCIAL").Lock = False
    ThisDrawing.Layers("MC_BLOCO_TEXTOS_INV").Lock = False
    program 'is this a sub of yours?
End Sub