Access VBA导出薪资条PDF并附加Outlook邮件时附件缺失问题排查

我有一个员工数据库，能生成月度薪资表和个人薪资条。个人薪资条是基于查询的报表，通过无绑定表单（带月份和员工字段）获取参数筛选。薪资条报表以**报表视图（Report View）**打开，报表上的命令按钮要实现：把报表存为PDF到指定文件夹、启动Outlook并格式化邮件（收件人、主题、正文等）。

目前按钮能正常保存PDF到指定文件夹并正确命名，Outlook邮件也能打开且格式正常，但邮件里没有附件。

以下是命令按钮的VBA代码：

Option Compare Database
Option Explicit

Private Sub cmdEmailPayslip_Click()

On Error GoTo cmdEmailPayslip_Error
    
Dim O As New Outlook.Application
Dim M As Outlook.MailItem
Dim Msg As String
Dim aTextBody As String
Dim myPath As String
Dim myFile As String
Dim mySubject As String

    mySubject = Me.FirstName.Column(1) & " " & Me.LastName.Column(1) & _
    " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy")
    
    aTextBody = "Dear " & Me.FirstName.Column(1) & "," & _
    Chr(10) & Chr(10) & "Please find attached your payslip for the month of " & _
    Format$(Forms!fSF!SFrom, "mmmm yyyy") & _
    Chr(10) & Chr(10) & "Best regards," & _
    Chr(10) & Chr(10) & "CIVIC EA OPS Team!"

    myPath = "C:\Payroll PESA\Payslips"
    
    myFile = Format$(Date, "yyyymmdd") & " - " & Me.FirstName.Column(1) & " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy")
    
    DoCmd.OutputTo acOutputReport, "rPayslips", acFormatPDF, myPath & "\" & myFile & ".pdf", False
    
Set O = New Outlook.Application
Set M = O.CreateItem(olMailItem)
    
On Error Resume Next

With M
    .Body = aTextBody                                    'Set body text
    .To = Me.REmail                                      'Set email address
    '.Cc = ""                                            'Set email CC address
    .Subject = mySubject                                 'Set subject
    .Attachment.Add myPath & "\" & myFile
    .Display
End With

Set M = Nothing
Set O = Nothing

'Show message
MsgBox "The email message has been sent successfully.  ", vbInformation, "EMail message"

cmdEmailPayslip_Error:
    Resume Next

End Sub

我试过多种调整都没用，请问哪里出错了？另外我考虑换一种方式：通过记录集生成单个PDF薪资条（保存到指定文件夹并命名），再创建带对应附件的单独邮件，但这超出我的理解范围，也希望能得到指导。

一、当前附件失败的直接原因 #

你在添加附件时漏掉了文件后缀.pdf：

• 导出PDF时用的完整路径是myPath & "\" & myFile & ".pdf"
• 但添加附件时写的是.Attachment.Add myPath & "\" & myFile，缺少.pdf后缀，Outlook找不到对应的文件，所以附件无法添加。

另外还有两个小问题：

1. 重复创建Outlook实例：一开始Dim O As New Outlook.Application，后面又Set O = New Outlook.Application，属于冗余操作，会浪费系统资源。
2. On Error Resume Next会掩盖附件添加失败的错误提示，导致你无法直接定位问题，建议调试阶段暂时注释掉。

二、修正后的代码 #

Option Compare Database
Option Explicit

Private Sub cmdEmailPayslip_Click()

On Error GoTo cmdEmailPayslip_Error
    
Dim O As Outlook.Application
Dim M As Outlook.MailItem
Dim aTextBody As String
Dim myPath As String
Dim myFile As String
Dim myFullFilePath As String '新增变量存储完整文件路径（含后缀）
Dim mySubject As String

    mySubject = Me.FirstName.Column(1) & " " & Me.LastName.Column(1) & _
    " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy")
    
    aTextBody = "Dear " & Me.FirstName.Column(1) & "," & _
    Chr(10) & Chr(10) & "Please find attached your payslip for the month of " & _
    Format$(Forms!fSF!SFrom, "mmmm yyyy") & _
    Chr(10) & Chr(10) & "Best regards," & _
    Chr(10) & Chr(10) & "CIVIC EA OPS Team!"

    myPath = "C:\Payroll PESA\Payslips"
    
    myFile = Format$(Date, "yyyymmdd") & " - " & Me.FirstName.Column(1) & " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy")
    myFullFilePath = myPath & "\" & myFile & ".pdf" '统一存储完整路径，避免重复拼接
    
    '导出PDF
    DoCmd.OutputTo acOutputReport, "rPayslips", acFormatPDF, myFullFilePath, False
    
    '仅创建一次Outlook实例
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
    
    '调试阶段注释掉错误忽略，方便定位问题
    'On Error Resume Next

    With M
        .Body = aTextBody
        .To = Me.REmail
        '.Cc = ""
        .Subject = mySubject
        .Attachments.Add myFullFilePath '使用完整路径，包含.pdf后缀
        .Display
    End With

    Set M = Nothing
    Set O = Nothing

    MsgBox "邮件已成功生成。", vbInformation, "邮件通知"

cmdEmailPayslip_Error:
    If Err.Number <> 0 Then
        MsgBox "错误代码: " & Err.Number & vbCrLf & "错误信息: " & Err.Description, vbCritical, "出错了"
    End If
    Resume Next
End Sub

三、关于记录集批量生成薪资条的思路（可选） #

如果需要批量给多个员工发送薪资条，用记录集的核心逻辑是遍历员工数据，逐个生成PDF和邮件：

1. 打开员工表/查询的记录集，遍历每条员工记录
2. 针对单个员工设置报表筛选条件，导出专属PDF
3. 生成对应邮件并添加附件，完成发送/显示

简化示例代码片段：

Dim rs As DAO.Recordset
'替换为你的员工表或查询名称，确保包含薪资条所需字段
Set rs = CurrentDb.OpenRecordset("SELECT EmployeeID, FirstName, LastName, REMail FROM Employees")

Do While Not rs.EOF
    '设置报表筛选条件（根据你的报表字段调整）
    Dim reportFilter As String
    reportFilter = "EmployeeID=" & rs!EmployeeID & " AND PayMonth=#" & Forms!fSF!SFrom & "#"
    
    '生成单个员工的PDF路径
    Dim empFileName As String
    empFileName = Format$(Date, "yyyymmdd") & " - " & rs!FirstName & " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy") & ".pdf"
    Dim empFullPath As String
    empFullPath = "C:\Payroll PESA\Payslips\" & empFileName
    
    '导出该员工的薪资条PDF
    DoCmd.OutputTo acOutputReport, "rPayslips", acFormatPDF, empFullPath, False, , reportFilter
    
    '创建邮件
    Dim O As Outlook.Application
    Dim M As Outlook.MailItem
    Set O = New Outlook.Application
    Set M = O.CreateItem(olMailItem)
    
    With M
        .Body = "Dear " & rs!FirstName & "," & vbCrLf & vbCrLf & "Please find attached your payslip for the month of " & Format$(Forms!fSF!SFrom, "mmmm yyyy") & vbCrLf & vbCrLf & "Best regards," & vbCrLf & vbCrLf & "CIVIC EA OPS Team!"
        .To = rs!REmail
        .Subject = rs!FirstName & " " & rs!LastName & " - Payslip for " & Format$(Forms!fSF!SFrom, "mmmm yyyy")
        .Attachments.Add empFullPath
        .Display '自动发送可改为.Send
    End With
    
    Set M = Nothing
    Set O = Nothing
    
    rs.MoveNext
Loop

rs.Close
Set rs = Nothing

内容的提问来源于stack exchange，提问作者Robert ZG