VBA宏问题：Outlook邮件无法附加文件、粘贴图表及插入签名

核心修复方案 #

针对你遇到的三个问题，下面是针对性的解决办法，附完整可运行代码：

问题修复细节 #

1. 临时文件附加失败 #

• 用系统临时目录（Environ("TEMP")）保存临时工作簿，规避权限或路径错误
• 确保临时工作簿仅保留Presentation工作表，删除多余表后再保存
• 保存后关闭临时工作簿，再执行附加操作，同时添加文件存在校验

2. 动态图表粘贴不准确 #

• 直接定位Presentation工作表中以B6为起始位置的嵌入图表（通过ChartObjects按位置或名称查找）
• 将图表复制为增强型图元文件（保证清晰度），插入到邮件正文签名前的位置

3. Outlook签名无法插入 #

• 创建邮件对象后先调用Display方法，触发Outlook自动加载默认签名
• 通过WordEditor对象定位签名位置，将内容精准插入到签名之前

修改后的完整VBA代码 #

Sub GenerateOutlookEmail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim TempWB As Workbook
    Dim PresSheet As Worksheet
    Dim ChartObj As ChartObject
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim wdDoc As Object ' Word.Document对象，用于编辑邮件正文
    
    ' 初始化变量
    Set PresSheet = ThisWorkbook.Worksheets("Presentation")
    TempFilePath = Environ("TEMP") & "\"
    TempFileName = "临时演示文件_" & Format(Now, "YYYYMMDDHHMMSS") & ".xlsx"
    
    ' --- 1. 创建并保存仅含Presentation的临时工作簿 ---
    Set TempWB = Workbooks.Add(xlWBATWorksheet)
    PresSheet.Copy Before:=TempWB.Sheets(1)
    Application.DisplayAlerts = False
    TempWB.Sheets(2).Delete ' 删除默认新建的空白工作表
    TempWB.SaveAs Filename:=TempFilePath & TempFileName, FileFormat:=xlOpenXMLWorkbook
    TempWB.Close SaveChanges:=False
    Application.DisplayAlerts = True
    
    ' --- 2. 创建Outlook邮件并加载签名 ---
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0) ' olMailItem
    
    On Error Resume Next
    With OutMail
        .To = "收件人邮箱@example.com" ' 替换为实际收件人邮箱
        .CC = ""
        .BCC = ""
        .Subject = "演示文件及动态图表"
        .Display ' 先显示邮件，触发Outlook自动加载签名
    End With
    On Error GoTo 0
    
    ' --- 3. 在签名前插入动态图表 ---
    Set wdDoc = OutMail.GetInspector.WordEditor
    ' 定位到签名前的位置：先移到正文末尾，再上移一行避开签名
    wdDoc.Application.Selection.EndKey Unit:=6 ' wdStory = 6
    wdDoc.Application.Selection.MoveUp Unit:=1, Count:=1
    
    ' 复制Presentation表中B6起始的图表（若有多个，可替换为ChartObjects("图表名称")）
    Set ChartObj = PresSheet.ChartObjects(1)
    ChartObj.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    ' 粘贴图表到邮件正文
    wdDoc.Application.Selection.Paste
    
    ' 可选：添加说明文本
    wdDoc.Application.Selection.TypeParagraph
    wdDoc.Application.Selection.TypeText "以上为最新动态演示图表"
    
    ' --- 4. 附加临时文件 ---
    On Error Resume Next
    If Dir(TempFilePath & TempFileName) <> "" Then
        OutMail.Attachments.Add TempFilePath & TempFileName
    Else
        MsgBox "临时文件未找到，无法附加"
    End If
    On Error GoTo 0
    
    ' 释放对象
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set TempWB = Nothing
    Set PresSheet = Nothing
    Set ChartObj = Nothing
    Set wdDoc = Nothing
    
    ' 可选：删除临时文件（若不需要保留）
    Kill TempFilePath & TempFileName
End Sub

关键代码说明 #

1. 临时工作簿处理：

   • 新建工作簿后复制目标工作表，删除默认空白表，确保临时文件仅含需要的内容
   • 用系统临时目录保存，避免因自定义路径权限不足导致的保存失败

2. 图表粘贴：

   • CopyPicture方法将图表转为图片格式，保证在邮件中正常显示
   • 通过WordEditor操作邮件正文，精准控制插入位置在签名之前

3. 签名加载：

   • 必须先调用.Display，Outlook才会自动插入默认签名
   • 利用Word的Selection对象移动光标，确保内容不会覆盖签名

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