VBA宏生成Outlook邮件时签名图片无法显示的解决求助

问题说明 #

使用Excel VBA宏生成Outlook邮件时，首次打开邮件签名图片显示正常，但后续签名图片无法加载。

核心问题 #

原代码中先通过WordEditor修改邮件内容，再拼接签名HTML，这个过程破坏了签名图片的本地资源引用路径，导致图片无法正常显示。

解决方案 #

调整操作顺序，先加载并保存签名，再处理邮件内容，最后直接将签名插入到邮件正文中，而非拼接HTML：

关键修改点 #

• 先调用.Display加载邮件签名，立即保存签名的原始HTML内容
• 避免通过拼接HTMLBody的方式组合正文与签名，改用WordEditor直接插入签名，保留图片引用
• 修复收件人列表开头的多余分号问题
• 完善EnableEvents的状态恢复

修改后的完整代码 #

Sub Email()
    If ActiveSheet.Name <> "Status" Then
        MsgBox "此宏仅能在Status工作表执行！"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim Signature As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim Mypath As String
    Dim maillist As String
    Dim LastMember As Long
    Dim rng As Range
    Dim sh As Excel.Worksheet
    Dim wdDoc As Word.Document
    
    Set sh = Sheets("Status")
    Set rng = sh.Range("B2:W61")
    rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' 先显示邮件加载签名，立即保存原始签名内容
    OutMail.Display
    Signature = OutMail.HTMLBody
    
    ' 生成收件人列表
    LastMember = Worksheets("Info").Cells(Rows.Count, 13).End(xlUp).Row
    For Each cell In ActiveWorkbook.Sheets("Info").Range("M2:M" & LastMember).Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value <> "" Then
            maillist = maillist & ";" & cell.Value
        End If
    Next
    ' 移除开头多余的分号
    If Left(maillist, 1) = ";" Then maillist = Mid(maillist, 2)
    
    ' 构建邮件开头正文
    Mypath = """" & ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & """"
    strbody = "<p>Dear all,</p>" & _
              "Please find below basware overview of today<br/>" & _
              "<A href=" & Mypath & ">Click here to open the file</A><br/><br/>"
    
    ' 将开头正文插入邮件，再粘贴表格图片
    Set wdDoc = OutMail.GetInspector.WordEditor
    wdDoc.Range.InsertBefore strbody
    wdDoc.Range.PasteAndFormat Type:=wdChartPicture
    wdDoc.InlineShapes(1).Height = 800
    
    ' 在正文末尾插入原始签名
    wdDoc.Range.InsertAfter vbCrLf & vbCrLf
    wdDoc.Range.InsertAfter Signature
    
    ' 设置邮件属性
    With OutMail
        .To = maillist
        .CC = "EMAILADDRESS@EMAIL.COM"
        .Subject = "AP - Basware Overview - " & Date
    End With
    
    ' 释放对象
    Set wdDoc = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

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