VBA嵌入图片在Mac Outlook桌面端不显示，求跨平台兼容方案

问题背景 #

原VBA代码实现了带嵌入二维码的邮件发送，在Windows Outlook桌面端、Win/Mac Outlook网页版均可正常加载图片，但Mac Outlook桌面端无法显示嵌入图片（已排除自动下载图片设置问题）。

原代码如下：

Dim OutApp As Object
Dim OutMail As Object
Dim fname As String

fname = "C:\Users\urdearboy\Desktop\(VBA)\Mail Send\QR_Code.jpg"
    
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .SentOnBehalfOfName = "fakeemail@fake.com"
    .to = Target
    .Subject = "Email with QR Code Attachement"
    .Attachments.Add fname, 1, 0
    .HTMLBody = "<font size=3>" _
      & "Hello " & Application.WorksheetFunction.Proper(Split(Target.Offset(, 2), " ")(0)) & ", " _
      & "<br><br>" _
      & "<img src=""cid:QR_Code.jpg""height=100 width=100>" _
      & "<br><br>" _
      & "Thanks, <br>" _
      & "urdearboy"
    
    .Send
End With

Set OutMail = Nothing
Set OutApp = Nothing

兼容解决方案 #

方案1：显式设置附件的Content ID属性 #

Mac Outlook对嵌入式图片的CID属性要求更严格，仅依赖文件名关联会失效，需通过MAPI属性显式绑定CID与附件。

修改后的代码：

Dim OutApp As Object
Dim OutMail As Object
Dim fname As String
Dim attach As Object
' 定义MAPI属性常量，用于设置附件的Content ID
Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"

fname = "C:\Users\urdearboy\Desktop\(VBA)\Mail Send\QR_Code.jpg"
    
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .SentOnBehalfOfName = "fakeemail@fake.com"
    .To = Target
    .Subject = "Email with QR Code Attachment"
    ' 添加附件并获取附件对象
    Set attach = .Attachments.Add(fname, 1, 0)
    ' 显式设置Content ID，确保与HTML中的cid完全一致（大小写敏感）
    attach.PropertyAccessor.SetProperty PR_ATTACH_CONTENT_ID, "QR_Code.jpg"
    
    .HTMLBody = "<font size=3>" _
      & "Hello " & Application.WorksheetFunction.Proper(Split(Target.Offset(, 2), " ")(0)) & ", " _
      & "<br><br>" _
      & "<img src=""cid:QR_Code.jpg"" height=""100"" width=""100"">" _
      & "<br><br>" _
      & "Thanks, <br>" _
      & "urdearboy"
    
    .Send
End With

Set attach = Nothing
Set OutMail = Nothing
Set OutApp = Nothing

方案2：Base64编码直接嵌入图片（无附件） #

将图片转换为Base64编码后直接写入HTML，彻底规避附件CID的跨平台兼容问题，所有Outlook平台均能正常显示。

完整代码：

' 将图片文件转换为Base64编码字符串
Function ImageToBase64(imagePath As String) As String
    Dim imgStream As Object
    Dim imgBytes() As Byte
    
    Set imgStream = CreateObject("ADODB.Stream")
    With imgStream
        .Type = 1 ' 二进制模式
        .Open
        .LoadFromFile imagePath
        imgBytes = .Read
        .Close
    End With
    
    ImageToBase64 = "data:image/jpeg;base64," & EncodeBase64(imgBytes)
End Function

' 二进制数据转Base64编码
Function EncodeBase64(inputBytes() As Byte) As String
    Dim objXML As Object
    Dim objNode As Object
    
    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = inputBytes
    EncodeBase64 = objNode.Text
    
    Set objNode = Nothing
    Set objXML = Nothing
End Function

' 主发送函数
Sub SendMailWithQRCode()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim fname As String
    Dim base64Img As String
    
    fname = "C:\Users\urdearboy\Desktop\(VBA)\Mail Send\QR_Code.jpg"
    base64Img = ImageToBase64(fname)
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .SentOnBehalfOfName = "fakeemail@fake.com"
        .To = Target
        .Subject = "Email with QR Code Attachment"
        
        .HTMLBody = "<font size=3>" _
          & "Hello " & Application.WorksheetFunction.Proper(Split(Target.Offset(, 2), " ")(0)) & ", " _
          & "<br><br>" _
          & "<img src=""" & base64Img & """ height=""100"" width=""100"">" _
          & "<br><br>" _
          & "Thanks, <br>" _
          & "urdearboy"
        
        .Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

方案对比 #

• 方案1：改动小，保留附件形式，适合快速适配原有代码逻辑
• 方案2：无附件依赖，兼容性拉满，但邮件体积会增大约37%（Base64编码特性）

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