Question

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

这是一个展示其外观的示例目录，其中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逐步完成了子程序，我在立即窗口中查看了调试打印。它似乎一直通过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

Answer 1

只是想让您知道我知道了。一切都按应有的方式运行，但是仍然找不到，跳过了某些文件。看来Office中的这个特定问题有问题。我将MS Office（所有应用程序）和Windows一起更新为最新的win10版本，并且可以正常工作！再次感谢

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

1 个答案: