【发布时间】：2026-01-06 04:20:03
【问题描述】：
我有一个用于创建电子邮件、附加文件的宏。它运行，我使用递归函数搜索目录以查找文件，将它们与电子表格中的字段匹配，然后在找到后附加它们。它工作并且已经工作了一段时间。但是，他们在目录中添加了一个级别，现在由于某种原因，它不起作用。我在这里只添加递归部分，因为那是错误发生的地方。
编辑：出于某种原因，从这个新的更高级别运行时，它会跳过所有文件名中包含数字的文件。这些文件名数字是宏用来与字段中的数字进行比较的，所以当它跳过它们时它会失败。那么为什么它现在会跳过它们，但在从根目录下的下一个子文件夹运行时工作正常？
这是一个显示其外观的示例目录，其中 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
【问题讨论】：
-
您能否更具体地说明您遇到的 what 错误以及发生在哪一行？另外，它最终在哪条线上停下来“放弃”？您是否有可能满足您的标准，然后在到达 SubfolderD 之前点击
Exit Function行？ -
抱歉，它只是在将文件附加到主子目录的那一行出错了。它在较低的子文件夹中有效，而不是从顶部根目录。它过去一直有效，直到用户添加了另一个子文件夹并告诉我他们将继续这样做。它似乎正在这样做......在它到达子文件夹D之前放弃，但这是递归的重点......它在找到匹配的文件之前不会这样做。错误在于无法添加附件，因为递归函数没有找到文件。它没有找到它，因为它停止查找。
-
如果不能看到你的其余代码，我将无法帮助你......也许其他人将能够推断出发生了什么，但是当你只看一张图片。
-
当然，我很高兴发布其余代码，只是不想混淆，因为到目前为止一切正常，唯一的错误是没有搜索这个新目录。跨度>
-
我的怀疑不是它没有被搜索，而是它正在被搜索并且没有任何内容符合您的标准 - 您确定您在文件夹中查找的内容存在吗？
标签： excel vba recursion outlook