如何在VBA的CDO邮件中添加临时工作簿附件？

这段VBA代码原本实现以下功能：

• 通过输入框收集三个问题的答案，写入工作簿指定单元格
• 将指定单元格区域复制到临时工作簿，再通过本地Outlook发送该临时文件到指定邮箱

如今终端服务器上的Outlook已被移除，需改用中继服务器（通过CDO.Message对象）发送邮件。目前代码已能创建临时文件、生成邮件，但不清楚如何将临时文件附加到邮件中。

Sub Mail_Week1_Maandag()

Dim userName As String
userName = InputBox("Aksie vir die dag?")
Range("'Data - Prod'!AD3").Value = userName
userName = InputBox("Hoeveel dissiplinêre vir die dag?")
Range("'Data - Prod'!AE3").Value = userName
userName = InputBox("Hoeveel bedankings vir die dag?")
Range("'Data - Prod'!AF3").Value = userName

Dim Email_Obj As Object
Dim Email_Configuration As Object
Dim Mail_Configuration As Variant
Dim Email_Sub As String
Dim Message_From As String
Dim Message_To As String
Dim Email_Cc As String
Dim Email_Bcc As String
Dim Message_Body As String
Dim AddAttachment As String

Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long

Set Source = Nothing
On Error Resume Next
Set Source = Worksheets("Data - Prod").Range("B3:AF3").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)

Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = wb.Name & " - Week 1 - Maandag"

If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If

Email_Sub = "PROD-OPSOMMING - " & wb.Name & " - Week 1 - Maandag"
Message_From = "email address"
Message_To = "email address"
Message_Body = "Sien aangeheg."
Set Email_Obj = CreateObject("CDO.Message")
On Error GoTo Error_Handling
Set Email_Configuration = CreateObject("CDO.Configuration")
Email_Configuration.Load -1
Set Mail_Configuration = Email_Configuration.Fields
With Mail_Configuration
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = xxxxx
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "xxxxx"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = xxxxx
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "xxxxx"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = xxxxx
.Update
End With

With Email_Obj
Set .Configuration = Email_Configuration
End With

With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next

With Email_Obj
.Subject = Email_Sub
.From = Message_From
.To = Message_To
.TextBody = Message_Body
.CC = Email_Cc
.BCC = Email_Bcc
.AddAttachment Dest.FullName
.Send
End With

On Error GoTo 0
.Close savechanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr

Error_Handling:
If Err.Description <> "" Then MsgBox Err.Description

MsgBox "Week 1-Maandag se data suksesvol gestuur!"
End Sub

使用CDO.Message的AddAttachment方法即可添加附件，你代码中已调用该方法，但需注意以下关键点以确保功能正常：

关键注意事项 #

1. 确认文件路径有效性
   在调用AddAttachment前，必须确保临时工作簿已成功保存到本地，Dest.FullName是保存后的完整路径，也可以提前拼接好路径变量（如tempFileFullPath），避免依赖对象属性可能出现的异常。

2. 完善SMTP中继配置
   你的CDO配置部分缺失关键参数，需根据中继服务器要求补充：

   • sendusing：固定填2（表示通过SMTP服务器发送）
   • smtpauthenticate：根据服务器验证方式，填0（无验证）、1（基本验证）或2（NTLM验证）
   • sendpassword：若服务器需要验证，必须添加此项
   • smtpusessl：若服务器要求SSL/TLS加密，设为True
   • smtpserverport：常见端口为25、587（TLS）或465（SSL）

3. 优化错误处理
   避免滥用On Error Resume Next，确保异常发生时能清理临时文件，防止垃圾文件残留。

修正后的完整代码 #

Sub Mail_Week1_Maandag()

    Dim userName As String
    ' 收集用户输入并写入指定单元格
    userName = InputBox("当日行动内容？")
    Range("'Data - Prod'!AD3").Value = userName
    userName = InputBox("当日纪律事件数量？")
    Range("'Data - Prod'!AE3").Value = userName
    userName = InputBox("当日感谢次数？")
    Range("'Data - Prod'!AF3").Value = userName

    Dim Email_Obj As Object
    Dim Email_Configuration As Object
    Dim Mail_Configuration As Variant
    Dim Email_Sub As String
    Dim Message_From As String
    Dim Message_To As String
    Dim Email_Cc As String
    Dim Email_Bcc As String
    Dim Message_Body As String

    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim tempFileFullPath As String

    ' 获取可见单元格区域
    Set Source = Nothing
    On Error Resume Next
    Set Source = Worksheets("Data - Prod").Range("B3:AF3").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    ' 检查区域是否有效
    If Source Is Nothing Then
        MsgBox "未找到可见单元格区域，无法继续！"
        Exit Sub
    End If

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)

    ' 复制数据到临时工作簿
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8 ' 复制列宽
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With

    ' 设置临时文件路径和名称
    TempFilePath = Environ$("temp") & "\"
    TempFileName = wb.Name & " - 第1周 - 周一"

    ' 根据Excel版本选择文件格式
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    tempFileFullPath = TempFilePath & TempFileName & FileExtStr

    ' 配置邮件参数
    Email_Sub = "生产总结 - " & wb.Name & " - 第1周 - 周一"
    Message_From = "你的发件邮箱@xxx.com"
    Message_To = "收件邮箱@xxx.com"
    Message_Body = "请查看附件。"

    ' 创建CDO邮件对象
    Set Email_Obj = CreateObject("CDO.Message")
    On Error GoTo Error_Handling

    ' 配置SMTP中继服务器
    Set Email_Configuration = CreateObject("CDO.Configuration")
    Email_Configuration.Load -1 ' 加载默认配置
    Set Mail_Configuration = Email_Configuration.Fields
    With Mail_Configuration
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "你的中继服务器地址"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 ' 基本验证，按需调整
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "中继服务器用户名"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "中继服务器密码" ' 按需添加
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 587 ' 按需调整
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True ' 按需调整
        .Update
    End With

    Set Email_Obj.Configuration = Email_Configuration

    ' 保存临时工作簿
    Dest.SaveAs tempFileFullPath, FileFormat:=FileFormatNum

    ' 发送邮件并添加附件
    With Email_Obj
        .Subject = Email_Sub
        .From = Message_From
        .To = Message_To
        .TextBody = Message_Body
        .CC = Email_Cc
        .BCC = Email_Bcc
        .AddAttachment tempFileFullPath ' 使用提前拼接的完整路径添加附件
        .Send
    End With

    ' 清理临时文件和工作簿
    Dest.Close savechanges:=False
    Kill tempFileFullPath

    MsgBox "第1周-周一数据已成功发送！"
    Exit Sub

Error_Handling:
    MsgBox "发送失败：" & Err.Description
    ' 异常时清理资源
    If Not Dest Is Nothing Then
        Dest.Close savechanges:=False
    End If
    If Dir(tempFileFullPath) <> "" Then
        Kill tempFileFullPath
    End If
End Sub

内容的提问来源于stack exchange，提问作者Alheit Augustyn