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

Question

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

[前2个宏将文件保存到downloads文件夹，而第3个宏当前正在输出，带有红色” 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 = "[email protected]; "
        '.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