VBA实现Outlook邮件添加附件报错问题排查与解决

问题描述 #

用VBA编写的代码实现Outlook发送带附件的邮件，逻辑是生成文件路径、保存Word文档后将其附加到邮件，但运行时反复弹出错误：无法找到此文件。请验证路径和文件名是否正确，已确认文件路径生成无误且文件确实存在。

原代码 #

Private Sub CommandButton1_Click()
    Dim OutlookApp As Object
    Dim OutlookMail As Object
    Dim OutlookMail2 As Object
    Dim WordDocument As Document
    Dim FilePath1 As String
    Dim FilePath2 As String
    Dim emailBody As String
    Dim userInput As String
    Dim userResponse As VbMsgBoxResult
    
    ' Create an instance of Outlook
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    Set OutlookMail2 = OutlookApp.CreateItem(0)
    
    Randomize
    
    Dim random4DigitNumber As String
    random4DigitNumber = Format(Int((9999 * Rnd) + 100), "0000")
    
    Dim ticketNumber As String
    Dim parts() As String
    parts = Split(TextBox1.Value, " ")
        ' Check if there's at least one part
    If UBound(parts) >= 0 Then
        ' Get the first value
        ticketNumber = Trim(parts(0))
        
        ' Display the first value
        MsgBox "First Value: " & ticketNumber
    Else
        MsgBox "No parts found in the string."
    End If
    
    ' Extract numeric part from ticketNumber
    Dim numericPart As String
    numericPart = VBA.Strings.Mid(ticketNumber, InStr(ticketNumber, "_") + 1)

    ' Use only the numeric part
    ticketNumber = Trim(numericPart)
    'ticketNumber = Trim(TextBox1.Value.Split("(")) ' Trim leading and trailing spaces
 
    ' Set the file path for the exported document
    FilePath1 = Environ("USERPROFILE") & "\Documents\PAP_" & ticketNumber & "_" & random4DigitNumber & ".docm"
    FilePath2 = Environ("USERPROFILE") & "\Documents\PAP_" & ticketNumber & "_" & random4DigitNumber & ".pdf"
    
    If ticketNumber = "" Then
        MsgBox "No value provided. Execution halted.", vbExclamation
        Exit Sub ' Exit the code
    End If
    
    userInput = InputBox("If you want to add something in the email body", "Email Body")
    
    emailBody = "Hello Team,<br><br>" & _
                "Please find attached PAP for the A+ ticket (<b>" & ticketNumber & "</b>).<br>" & _
                 userInput & "<br><br>Regards,<br>" & Application.UserName
    
    userResponse = MsgBox("Are you sure you want to send the file?", vbOKCancel)
    
    If userResponse <> vbOK Then
        Exit Sub
    End If
    
    ' Save the active document with a new name
    ActiveDocument.SaveAs2 FilePath1, FileFormat:=wdFormatXMLDocumentMacroEnabled

    MsgBox Dir(FilePath1)
    
    ' Configure the email
    With OutlookMail
        .To = "xyz.abc.com"
        .Cc = "xyz.gef.com"
        .Subject = "Preventive Action Plan - " & ticketNumber
        .HTMLBody = emailBody
        .Attachments.Add FilePath1
        ' Display the email for the user to review (optional)
        .Display
        
        ' Send the email
        '.Send
    End With

End Sub

原因排查 #

1. 文件锁定：ActiveDocument.SaveAs2执行后，Word进程可能仍在占用该文件（未完成写入或持有锁），此时Outlook尝试访问文件会被拒绝，错误提示有误导性，实际是权限/锁定问题而非文件不存在。
2. 不可见字符污染路径：ticketNumber提取过程中可能残留换行、制表符等不可见字符，导致生成的路径表面正确但实际无效。
3. Dir函数的局限性：MsgBox Dir(FilePath1)仅能验证文件存在，无法检测文件是否处于锁定状态。

解决方法 #

方法1：释放Word文档锁定 #

保存文档后，直接关闭文档（已保存过无需再存），彻底释放文件锁：

' 保存文档后添加该行
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

如果需要保持文档打开，可添加短暂延迟等待Word完成写入：

' 保存后添加2秒延迟（根据实际情况调整）
Application.Wait Now + TimeValue("00:00:02")

方法2：清理ticketNumber的不可见字符 #

在提取ticketNumber后，添加代码清除所有可能的不可见字符：

' 清除换行、制表符等不可见字符
ticketNumber = Replace(Replace(ticketNumber, vbCr, ""), vbLf, "")
ticketNumber = Replace(ticketNumber, vbTab, "")
ticketNumber = Trim(ticketNumber)

方法3：添加附件前验证文件可访问性 #

在添加附件前，先检查文件是否能被正常读取，避免错误：

' 替换原.Attachments.Add FilePath1的代码
If Dir(FilePath1) <> "" Then
    On Error Resume Next
    Open FilePath1 For Input As #1
    Close #1
    If Err.Number = 0 Then
        .Attachments.Add FilePath1
    Else
        MsgBox "文件被锁定，无法添加附件：" & FilePath1, vbCritical
        Exit Sub
    End If
    On Error GoTo 0
Else
    MsgBox "文件不存在：" & FilePath1, vbCritical
    Exit Sub
End If

优化后的关键代码片段 #

整合上述修复后的核心部分：

' ... 之前的代码 ...

' Save the active document with a new name
ActiveDocument.SaveAs2 FilePath1, FileFormat:=wdFormatXMLDocumentMacroEnabled

' 释放文件锁：关闭文档
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges

' Configure the email
With OutlookMail
    .To = "xyz.abc.com"
    .Cc = "xyz.gef.com"
    .Subject = "Preventive Action Plan - " & ticketNumber
    .HTMLBody = emailBody
    ' 验证文件可访问后添加附件
    If Dir(FilePath1) <> "" Then
        On Error Resume Next
        Open FilePath1 For Input As #1
        Close #1
        If Err.Number = 0 Then
            .Attachments.Add FilePath1
        Else
            MsgBox "文件被锁定，无法添加附件：" & FilePath1, vbCritical
            Exit Sub
        End If
        On Error GoTo 0
    Else
        MsgBox "文件不存在：" & FilePath1, vbCritical
        Exit Sub
    End If
    .Display
    '.Send
End With

内容的提问来源于stack exchange，提问作者Sumeet Arora