excel - VBA 递归搜索子文件夹并附加匹配文件

问题描述

我有一个用于创建电子邮件、附加文件的宏。它运行，我使用递归函数搜索目录以查找文件，将它们与电子表格中的字段匹配，然后在找到后附加它们。它工作并且已经工作了一段时间。但是，他们在目录中添加了一个级别，现在由于某种原因，它不起作用。我在这里只添加递归部分，因为那是错误发生的地方。
编辑：出于某种原因，当从这个新的更高级别运行时，它会跳过文件名中包含数字的所有文件。这些文件名数字是宏用来与字段中的数字进行比较的，因此当它跳过它们时会失败。那么为什么它现在会跳过它们，但是从根目录的下一个子文件夹运行时可以正常工作呢？

这是一个显示其外观的示例目录，其中 Division 是根顶级文件夹。SubfolderD 是我想要它到达的地方，找到数据：

Division-->SubfolderA-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderB-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderC-->Subfolder2-->Subfolder3-->Etc
Division-->SubfolderD-->Subfolder2-->Subfolder3-->Etc

我可以调整功能以在 SubfolderD 中搜索，它会找到文件。问题是将添加新文件夹并且要找到的文件可能在其他文件夹中。所以我需要让它从 Division 文件夹中始终如一地工作。我已经用 F8 单步执行了 sub，并查看了立即窗口中的调试打印。它似乎一直通过 SubfolderC，但随后停止并且由于某种原因似乎放弃了。有什么想法吗？谢谢

Function recurse(sPath As String, strname As String, strName3 As String)

Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder
Dim mySubFolder As Scripting.Folder
Dim myFile As Scripting.file


Dim strJDFile As String
Dim strDir As String
Dim strJDName As String


Set myFolder = FSO.GetFolder(sPath)

' strName = Range("a2").Offset(0, 3)
strName3 = Replace(strName3, "/", " ")

For Each mySubFolder In myFolder.SubFolders

Debug.Print " mySubFolder: " & mySubFolder

For Each myFile In mySubFolder.Files



    If "*" & myFile.Name & "*" Like "*" & strName3 & "*" Then
        strJDName = myFile.Name
        strDir = mySubFolder & "\"
        strJDFile = strDir & strJDName

        recurse = strJDFile

        Exit Function

    Else
        Debug.Print "  myFile.name: " & myFile.Name

    End If

Next

recurse = recurse(mySubFolder.Path, strname, strName3)

Next

End Function

编辑发布整个子：

Option Compare Text
Sub Recursive()
'
'
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim strDir As String
    Dim strFilename As String
    Dim sigString As String
    Dim strBody As String
    Dim strname As String
    Dim strName1 As String
    Dim strName3 As String
    Dim strDept As String
    Dim strName2 As String
    Dim LR As Long
    Dim oItem As Object
    Dim dteSat As Date
    Dim nextSat As Date

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    sigString = Environ("appdata") & _
                "\Microsoft\Signatures\Test.htm"

        If Dir(sigString) <> "" Then
         signature = GetBoiler(sigString)
         Else
         signature = ""
        End If

        Select Case Time
           Case 0.25 To 0.5
                GreetTime = "Good morning"
           Case 0.5 To 0.71
                GreetTime = "Good afternoon"
           Case Else
                GreetTime = "Good evening"
        End Select

        With ActiveSheet
         With .Columns(2)
         .NumberFormat = "General"
         .TextToColumns Destination:=.Cells(1), _
                       DataType:=xlFixedWidth, fieldinfo:=Array(0, 1)
         End With
        End With

        With Item
        K = Weekday(Today)
        dteSat = Now() + (10 - K)

        nextSat = Date + 7 - Weekday(Date, vfSaturday)
        End With

        LR = ActiveSheet.UsedRange.Rows.Count
        Columns("z:z").Select
        Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        Range("z2") = "Yes"
        Range("z2").AutoFill Destination:=Range("z2:z" & LR)

    For Each cell In Columns("J").Cells.SpecialCells(xlCellTypeConstants)

        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "z").Value) = "yes" Then
            Set OutMail = OutApp.CreateItem(0)


        With OutMail
            strName3 = Cells(cell.Row, "b").Value
            strName1 = Cells(cell.Row, "d").Value
            strName2 = Trim(Split(strName1, " ")(1))
            strname = Cells(cell.Row, "a").Value

            strJDFile = recurse("z:\Division", strname, strName3)

            strBody = "<Font Face=calibri><br><br>The form needs to be completed no later " & _
            "than next week. <br><br>" & _



                .SentOnBehalfOfName = ""
                .To = cell.Value
                .Subject = "Please Reply"
                .HTMLBody = "<Font Face=calibri>" & GreetTime & " " & strName1 & ", " & strBody & "<br>" & signature
                .Attachments.Add strJDFile
                .Display  'Or use Send
        End With

            Set OutMail = Nothing
        End If
    Next cell

End Sub



Function GetBoiler(ByVal sFile As String) As String
    Dim FSO As Object
    Dim ts As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.ReadAll
    ts.Close
End Function


Function recurse(sPath As String, strname As String, strName3 As String)

Dim FSO As New FileSystemObject
Dim myFolder As Scripting.Folder
Dim mySubFolder As Scripting.Folder
Dim myFile As Scripting.file


Dim strJDFile As String
Dim strDir As String
Dim strJDName As String


Set myFolder = FSO.GetFolder(sPath)

' strName = Range("a2").Offset(0, 3)
strName3 = Replace(strName3, "/", " ")

For Each mySubFolder In myFolder.SubFolders

    Debug.Print " mySubFolder: " & mySubFolder

    For Each myFile In mySubFolder.Files



        If "*" & myFile.Name & "*" Like "*" & strName3 & "*" Then
            strJDName = myFile.Name
            strDir = mySubFolder & "\"
            strJDFile = strDir & strJDName

            recurse = strJDFile

            Exit Function

        Else
            Debug.Print "  myFile.name: " & myFile.Name

        End If

    Next

    recurse = recurse(mySubFolder.Path, strname, strName3)

Next

End Function

标签： excelvbarecursionoutlook

excel - VBA 递归搜索子文件夹并附加匹配文件

问题描述

解决方案

推荐阅读