Excel VBA导出带图片工作表为Outlook邮件正文异常问题求解

• 弹窗问题：代码中使用了Application.GetOpenFilename方法，该方法的作用就是弹出文件选择对话框供用户手动选择文件，所以每次运行都会触发弹窗。
• 外部收件人看不到图片问题：
  1. 原代码使用Pictures.Insert方法默认以链接形式插入图片，图片并未嵌入文件，生成HTML时只会保留本地文件路径，外部用户无法访问你的本地路径
  2. 原代码插入图片时指定的是ActiveSheet，实际应该插入到用来生成HTML的临时工作簿TempWB的工作表中，之前的逻辑插错了工作表，导致临时表根本没有图片
  3. 生成HTML后的图片资源默认是本地相对路径，需要转换为邮件内嵌的CID引用格式，外部用户才能正常加载

调整说明 #

1. 提前定义好公司logo的固定本地路径，删除手动选择文件的代码，解决弹窗问题
2. 使用Shapes.AddPicture方法插入图片，指定嵌入而非链接，确保图片保存在临时工作簿中
3. 将图片作为邮件的隐藏内嵌附件，替换HTML中图片的本地路径为CID引用，确保外部收件人可以正常加载

完整修正代码 #

按钮触发子程序 #

Private Sub CommandButton1_Click()
    ' 请修改为你自己的logo实际存放的完整本地路径
    Const LOGO_PATH As String = "C:\公司素材\官方logo.png"
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cid As String
    cid = "company_logo" ' 自定义图片CID标识
    
    Set rng = Nothing
    Set rng = ActiveSheet.Range("B2:L67").SpecialCells(xlCellTypeVisible)
    If rng Is Nothing Then
        MsgBox "选择的不是有效单元格区域或工作表已保护，请调整后重试。", vbOKOnly
        Exit Sub
    End If
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .Subject = ActiveSheet.Range("R3").Value
        ' 添加logo作为隐藏内嵌附件
        .Attachments.Add LOGO_PATH, 1, 0
        .Attachments(1).PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x3712001F", cid
        ' 生成HTML并替换图片路径为CID
        .HTMLBody = Replace(RangetoHTML(rng, LOGO_PATH), "src=""{logo_placeholder}""", "src=""cid:" & cid & """")
        .Display
    End With
    
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

修正后的RangetoHTML转换函数 #

Function RangetoHTML(rng As Range, logoPath As String)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        Application.CutCopyMode = False
        
        ' 直接在临时工作表插入嵌入格式的logo，不弹选择框
        .Shapes.AddPicture _
            Filename:=logoPath, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=.Range("D2").Left, _
            Top:=.Range("D2").Top, _
            Width:=.Range("D2:H2").Width, _
            Height:=.Range("D2:D6").Height
    End With
    
    With TempWB.PublishObjects.Add( _
      SourceType:=xlSourceRange, _
      Filename:=TempFile, _
      Sheet:=TempWB.Sheets(1).Name, _
      Source:=TempWB.Sheets(1).UsedRange.Address, _
      HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    ' 替换HTML对齐属性和图片路径为占位符
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    RangetoHTML = Replace(RangetoHTML, "src=""" & TempWB.Sheets(1).Shapes(1).PictureFormat.Filename & """", "src=""{logo_placeholder}""")
    
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

注意事项 #

如果运行时提示msoFalse或msoTrue未定义，直接替换为对应数值即可：msoFalse = 0，msoTrue = -1。

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