嵌入图像未显示在电子邮件 VBA 上

Question

我有一些代码可以发送电子邮件，但嵌入的图像显示为红色“X”。 对 C19 的引用是“Image.png”（此文件名会根据其他数据不断变化）和文件名。

前两个宏将文件保存到下载文件夹，第三个宏当前正在输出一个红色的“X”。

Sub CandidCamera()

   Sheets("Total Hours Check").Range("M5").AutoFilter Field:=2, Criteria1:="<>"
   If Sheets("Total Hours Check").Range("N6") > 0 Then
   Call CapturePivottable
   Else
   MsgBox "No High Hours Reported"
   Exit Sub
   End If
End Sub

Private Sub CapturePivottable()

    Dim si As Excel.SlicerItem, siDummy As Excel.SlicerItem
    Dim pt As Excel.PivotTable
    Dim co As Excel.ChartObject
    Dim wsBlank As Excel.Worksheet

    Set pt = Sheets("Total Hours Check").PivotTables(1)

    ' add a blank sheet to get a blank Chart instead of PivotChart later
    Set wsBlank = ActiveWorkbook.Sheets.Add


        With pt.TableRange2 ' or TableRange1
            .CopyPicture Appearance:=xlScreen, Format:=xlPicture
            Set co = wsBlank.ChartObjects.Add(1, 1, .Width, .Height)
            co.Select
            co.Chart.Paste
            co.Chart.Export _
                Filename:=Environ("USERPROFILE") & "\Downloads\" & Sheets("Private").Range("B7").Value & ".png", filtername:="PNG"


            co.Delete
        End With

Call Email

    Application.DisplayAlerts = False
    wsBlank.Delete
    Application.DisplayAlerts = True

End Sub

Sub Email()


'Sends the last saved version of the Activeworkbook
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Worksheets("Private").Range("A19").Value
        .CC = "email1@gmail.com; "
        '.BCC = ""
        .Subject = Worksheets("Private").Range("H29").Value
        '.Body =
        .Attachments.Add ActiveWorkbook.FullName
        .Attachments.Add Filepath, olByValue, 1
            Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename
            Filename = Sheets("Private").Range("C19").Value
        .HTMLBody = "<img src=cid:Filename></img>"
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")

        .Display   'or use .Send


    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Answer 1

Filename = Sheets("Private").Range("A19")
Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set colattach = OutMail.Attachments
Set oAttach = colattach.Add(Filepath)
Set olkPA = oAttach.PropertyAccessor

Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"


'--- Rest of code

.HTMLBody = "<IMG src =""cid:Filename"">"

'--- Rest of code

Answer 2

问题在于 HTML Body 语句。我添加了引号，它现在可以正确嵌入。

Sub Email()


'Sends the last saved version of the Activeworkbook
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Filepath As String
    Dim Filename As String

    Filename = Sheets("Private").Range("C19").Value
    Filepath = Environ("USERPROFILE") & "\Downloads\" & Filename

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = Worksheets("Private").Range("A19").Value
        '.BCC =
        .Subject = Worksheets("Private").Range("H29").Value
        '.Body =
        .Attachments.Add ActiveWorkbook.FullName
        .Attachments.Add Filepath, olByValue, 0
        'Change "1" value to 0 to hide
        .HTMLBody = "<img src=""" & Filepath & """>"
        'You can add other files also like this
        '.Attachments.Add ("C:\test.txt")

        .Display   'or use .Send


    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub