Outlook外部收件人无法查看VBA插入的HTML图片问题及代码优化咨询

算力阿峰

2026-10-5

Outlook 嵌入式HTML图片外部不可见问题解决方案及VBA代码优化

问题说明

我认为2020年初Outlook的一次更新导致插入的HTML图片对外部收件人不可见。
我之前就职的公司有开发人员编写过相关代码可实现图片正常显示，我本人此前及现在都不精通编码，一直在拼凑相关代码但未能解决该问题，甚至不知道从何处入手，恳请提供相关解决方案。
如果下方提供的VBA代码有可优化精简的地方，也请告知。

原提交VBA代码

Sub Email()

    'Create and assign email variables
    Dim OutApp As Object
    Dim OutMail As Object
    'Create and assign JPEF variable
    Dim MakeJPG As String
    'create and assign workbook variable
    Dim wb As Workbook
    'create and assign File path variable
    Dim Filepath As String
    'Create and assign File name variable
    Dim Filename As String
    'Create and assign File date variable
    Dim Filedate As String
    'Create and assign Folder Year variable
    Dim folderyear As String

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Filepath = Format(Range("filepath"))
    Filename = Format(Range("filename"))
    Filedate = Format(Range("trade_date"), "ddmmmyyyy")
    folderyear = Format(Range("trade_date"), "yyyy")

    '========================================================================
    'Copy range you want to paste on new worksheet
    Worksheets("Sheet1").Range("A1:Q31").Copy

    'Open new workbook
    Set wb = Workbooks.Add
    Application.DisplayAlerts = False

    'paste copied range
    ActiveSheet.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone, SkipBlanks:=False
    ActiveSheet.Paste

    'Adjust Window Zoom
    ActiveWindow.Zoom = 80

    'Adjust Gridlines
    ActiveWindow.DisplayGridlines = False

    'Adjust Header Row Height
    Rows("2:5").Select
    Selection.RowHeight = 25.5
    Rows("6").Select
    Selection.RowHeight = 21

    'Adjust DA Sales Column Width
    Columns("A").ColumnWidth = 6
    Columns("B").ColumnWidth = 12
    Columns("C").ColumnWidth = 14
    Columns("D:E").ColumnWidth = 10
    Columns("F").ColumnWidth = 39
    Columns("G").ColumnWidth = 10
    Columns("H").ColumnWidth = 16

    'Adjust RT Sales Column Width
    Columns("I").ColumnWidth = 4
    Columns("J").ColumnWidth = 12
    Columns("K").ColumnWidth = 14
    Columns("L:M").ColumnWidth = 10
    Columns("N").ColumnWidth = 39
    Columns("O").ColumnWidth = 10
    Columns("P").ColumnWidth = 16
    Columns("Q").ColumnWidth = 6

    'Rename worksheet
    ActiveSheet.Name = "Sheet1"

    'Save new worksheet with pasted range
    wb.SaveAs Filename:=Filepath & Filename & " " & Filedate & ".xlsx"
    Application.DisplayAlerts = True

    'Close active workbook
    ActiveWorkbook.Close True
    '========================================================================
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    '========================================================================
    'Create JPG file of the range
    'Only enter the Sheet name and the range address
    MakeJPG = CopyRangeToJPG("Sheet1", "A1:Q31")

    If MakeJPG = "" Then
        MsgBox "Something went wrong, can't create email"
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        Exit Sub
    End If

    On Error Resume Next
    '========================================================================
    With OutMail
        .SentOnBehalfOfName = "My Company"
        .BodyFormat = olFormatHTML
        .Display
    End With
    Signature = OutMail.HTMLBody
    '========================================================================
    'Define & Assign To email list using a named range
    Set emailRng = Worksheets("Sheet1").Range("to_email")
    For Each cl In emailRng
        sTo = sTo & ";" & cl.Value
    Next
    sTo = Mid(sTo, 2)

    'Define & Assign CC email list
    Set emailRng2 = Worksheets("Sheet1").Range("cc_email")
    For Each cl2 In emailRng2
        sCc = sCc & ";" & cl2.Value
    Next
    sCc = Mid(sCc, 2)
    '========================================================================
    With OutMail
        .To = sTo '"Manually enter email address here"
        .cc = sCc '"Manually enter email address here"
        .BCC = ""
        .Subject = Filename & " " & Range("trade_date")
        .Attachments.Add MakeJPG, 1, 0
        'Note: Change the width and height as needed
        .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=1150 height=600></html>" & "<br><br>" & Signature & "<br><br>"
        .Attachments.Add Filepath & Filename & " " & Filedate & ".xlsx"
        .Display 'or use .Send
    End With
            
    On Error GoTo 0

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
'========================================================================
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    Dim PictureRange As Range

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            On Error GoTo 0
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With

    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function

问题修复及代码优化说明

图片外部不可见核心原因

Outlook 2020更新后对嵌入式CID图片的校验规则收紧，原有代码仅通过文件名匹配CID的方式不稳定，外部邮件传输过程中附件标识容易被改写，导致图片无法加载。

修复逻辑

显式设置附件的PR_ATTACH_CONTENT_ID属性，确保CID和HTML中的src完全匹配，不会被传输过程改写
修正HTMLBody结构，避免重复添加标签和原有签名的HTML结构冲突
导出图片时添加时间戳命名，避免多封邮件发送时的缓存冲突

代码优化点

补充所有缺失的变量声明，避免未定义变量报错
移除无用的Select/Selection操作，优化运行速度
统一代码缩进，提升可读性
新增错误捕获分支，避免异常情况下Excel设置无法恢复
优化邮件地址拼接逻辑，空列表时不会生成无效的前置分号

优化后完整可运行代码

Option Explicit
Sub 发送邮件()
    Dim OutApp As Object, OutMail As Object
    Dim MakeJPG As String, wb As Workbook
    Dim Filepath As String, Filename As String, Filedate As String, folderyear As String
    Dim emailRng As Range, cl As Range, emailRng2 As Range, cl2 As Range
    Dim sTo As String, sCc As String, Signature As String, strbody As String
    Dim oAtt As Object, PA As Object
    Const PR_ATTACH_CONTENT_ID As String = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
    ' 关闭屏幕更新和事件触发
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    On Error GoTo ErrHandler
    
    ' 读取配置单元格
    Filepath = Range("filepath").Value
    Filename = Range("filename").Value
    Filedate = Format(Range("trade_date").Value, "ddmmmyyyy")
    folderyear = Format(Range("trade_date").Value, "yyyy")
    strbody = "这里填写邮件正文内容" ' 可根据需求自定义
    
    ' 复制区域生成附件文件
    Worksheets("Sheet1").Range("A1:Q31").Copy
    Set wb = Workbooks.Add
    With ActiveSheet
        .Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        .Name = "Sheet1"
        ' 调整格式
        ActiveWindow.Zoom = 80
        ActiveWindow.DisplayGridlines = False
        .Rows("2:5").RowHeight = 25.5
        .Rows("6").RowHeight = 21
        .Columns("A").ColumnWidth = 6
        .Columns("B").ColumnWidth = 12
        .Columns("C").ColumnWidth = 14
        .Columns("D:E").ColumnWidth = 10
        .Columns("F").ColumnWidth = 39
        .Columns("G").ColumnWidth = 10
        .Columns("H").ColumnWidth = 16
        .Columns("I").ColumnWidth = 4
        .Columns("J").ColumnWidth = 12
        .Columns("K").ColumnWidth = 14
        .Columns("L:M").ColumnWidth = 10
        .Columns("N").ColumnWidth = 39
        .Columns("O").ColumnWidth = 10
        .Columns("P").ColumnWidth = 16
        .Columns("Q").ColumnWidth = 6
    End With
    
    ' 保存附件Excel
    wb.SaveAs Filename:=Filepath & Filename & " " & Filedate & ".xlsx"
    wb.Close SaveChanges:=True
    
    ' 生成区域截图
    MakeJPG = CopyRangeToJPG("Sheet1", "A1:Q31")
    If MakeJPG = "" Then
        MsgBox "生成截图失败，无法创建邮件"
        GoTo Cleanup
    End If
    
    ' 创建Outlook邮件
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' 获取默认签名
    With OutMail
        .SentOnBehalfOfName = "My Company"
        .BodyFormat = 2 ' olFormatHTML 晚绑定直接用数值避免引用报错
        .Display
        Signature = .HTMLBody
    End With
    
    ' 拼接收件人列表
    Set emailRng = Worksheets("Sheet1").Range("to_email")
    For Each cl In emailRng
        If Trim(cl.Value) <> "" Then sTo = sTo & ";" & Trim(cl.Value)
    Next
    If sTo <> "" Then sTo = Mid(sTo, 2)
    
    Set emailRng2 = Worksheets("Sheet1").Range("cc_email")
    For Each cl2 In emailRng2
        If Trim(cl2.Value) <> "" Then sCc = sCc & ";" & Trim(cl2.Value)
    Next
    If sCc <> "" Then sCc = Mid(sCc, 2)
    
    ' 组装邮件内容
    With OutMail
        .To = sTo
        .cc = sCc
        .BCC = ""
        .Subject = Filename & " " & Range("trade_date").Value
        ' 添加截图并设置固定CID
        Set oAtt = .Attachments.Add(MakeJPG, 1, 0)
        Set PA = oAtt.PropertyAccessor
        PA.SetProperty PR_ATTACH_CONTENT_ID, "NamePicture.jpg"
        ' 修正HTML结构避免冲突
        .HTMLBody = "<p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=1150 height=600><br><br>" & Signature
        ' 添加Excel附件
        .Attachments.Add Filepath & Filename & " " & Filedate & ".xlsx"
        .Display ' 需要自动发送改为.Send即可
    End With
    
Cleanup:
    ' 恢复Excel设置
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
    ' 释放对象
    Set oAtt = Nothing
    Set PA = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
    Set wb = Nothing
    Set emailRng = Nothing
    Set emailRng2 = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "运行出错：" & Err.Description
    Resume Cleanup
End Sub

Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    Dim PictureRange As Range, imgName As String
    ' 添加时间戳避免文件名冲突
    imgName = "NamePicture_" & Format(Now(), "YYYYMMDDHHMMSS") & ".jpg"
    
    With ActiveWorkbook
        On Error Resume Next
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        If Err.Number <> 0 Or PictureRange Is Nothing Then
            MsgBox "无效的截图区域"
            On Error GoTo 0
            Exit Function
        End If
        On Error GoTo 0
        
        PictureRange.CopyPicture xlScreen, xlPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & imgName, "JPG"
            .Delete
        End With
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & imgName
    Set PictureRange = Nothing
End Function

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

Outlook外部收件人无法查看VBA插入的HTML图片问题及代码优化咨询

问题说明 #

原提交VBA代码 #

问题修复及代码优化说明 #

图片外部不可见核心原因 #

修复逻辑 #

代码优化点 #

优化后完整可运行代码 #