VBA发送邮件时签名图片显示正常但收件方无法查看问题

问题原因 #

直接调用.Send时，Outlook不会自动将签名HTML中的本地图片路径转换为邮件内嵌的CID（Content ID）关联。使用.Display或手动发送时，Outlook会触发内部机制，把本地图片作为内嵌附件添加到邮件中，并将HTML里的图片路径替换为对应的cid:链接，收件方才能正常显示。但直接.Send跳过了这个过程，HTML里还是本地绝对路径，收件方无法访问你的本地文件，所以显示空白框；发给自己时本地有该图片，所以能正常加载。

代码存在的问题 #

你直接读取签名HTML文件的内容拼接到邮件HTMLBody，没有让Outlook完成签名图片的内嵌转换流程。Ron DeBruin的方法在.Display时有效是因为Outlook自动处理了图片，但.Send时需要手动触发这个处理。

解决方案1：用GetInspector触发签名图片处理 #

在设置HTMLBody后，调用OutMail.GetInspector触发Outlook的邮件内容解析，让它自动将签名里的图片转换为内嵌附件。修改发送部分的代码即可：

完整修改后的代码

Option Explicit

Sub NOTIFICATIONS()
   Dim OutApp As Object
   Dim OutMail As Object
   Dim strbody As String
   Dim strname As String
   Dim strname1 As String
   Dim strEmp As String
   Dim previousName As String
   Dim nextName As String
   Dim emailWS As Worksheet
   Dim nameCol As Double
   Dim nameCol2 As Double
   Dim empCol As Double
   Dim lastRow As Double
   Dim startRow As Double
   Dim r As Double
   Dim sigstring As String
   Dim Signature As String
   Dim empList As String
   Dim insp As Object ' 新增Inspector对象
   
   ' 获取签名路径
   sigstring = Environ("appdata") & "\Microsoft\Signatures\Notifications.htm"
   
   If Dir(sigstring) <> "" Then
      Signature = GetBoiler(sigstring)
   Else
      Signature = ""
   End If
   
   Set OutApp = CreateObject("Outlook.Application")
   Set emailWS = ActiveSheet
   startRow = 2
   nameCol = 3
   nameCol2 = 1
   empCol = 5
   lastRow = emailWS.Cells(emailWS.Rows.Count, nameCol).End(xlUp).Row
   
   For r = startRow To lastRow
      strname = emailWS.Cells(r, nameCol2).Value
      strname1 = Trim(Split(emailWS.Cells(r, nameCol2), ",")(1))
      strEmp = emailWS.Cells(r, empCol).Value
      
      If emailWS.Cells(r + 1, nameCol2) <> "" Then
         nextName = emailWS.Cells(r + 1, nameCol2).Value
      Else
         nextName = "Exit"
      End If
      
      If strname <> previousName Then
         previousName = strname
         Set OutMail = OutApp.CreateItem(0)
         With OutMail
            .To = emailWS.Cells(r, 2).Value
            .Subject = "Please Review Updated Information "
            empList = strEmp & "<br>"
            strbody = "<Font Face=calibri>Dear " & strname1 & ", <br><br> " & _
            "Please review the below."
         End With
      Else
         If InStr(empList, strEmp) = 0 Then
            empList = empList & strEmp & "<br>"
         End If
      End If
      
      If strname <> nextName Then
         OutMail.HTMLBody = strbody & "<B>" & empList & "</B>" & "<br>" & Signature
         ' 触发Inspector处理签名图片
         Set insp = OutMail.GetInspector
         ' 重新赋值HTMLBody确保CID关联生效
         OutMail.HTMLBody = OutMail.HTMLBody
         OutMail.Send
      End If
      
      If emailWS.Cells(r + 1, nameCol2) = "" Then
         Exit Sub
      End If
   Next r
   
   Set OutMail = Nothing
   Set OutApp = Nothing
   Set insp = Nothing
End Sub

Function GetBoiler(ByVal sFile As String) As String
   Dim fso As Object
   Dim ts As Object
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
   GetBoiler = ts.ReadAll
   ts.Close
End Function

解决方案2：手动嵌入图片（不依赖签名） #

如果不想依赖签名的图片处理，可以手动将图片作为内嵌附件添加到邮件中，用CID引用，这种方法更可控：

核心修改代码片段

If strname <> nextName Then
    ' 替换为你的图片绝对路径
    Dim imgPath As String
    imgPath = "C:\你的图片路径\signature_logo.png"
    
    ' 添加图片为附件并设置Content ID
    Dim imgAttach As Object
    Set imgAttach = OutMail.Attachments.Add(imgPath)
    Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    imgAttach.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, "sigLogo"
    
    ' 在HTML中引用CID
    strbody = strbody & "<B>" & empList & "</B>" & "<br><br>" & _
              "<img src='cid:sigLogo' alt='Signature Logo'>"
              
    OutMail.HTMLBody = strbody
    OutMail.Send
End If

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