Встроенное изображение не отображается в электронной почте VBA

Question

У меня есть код для отправки электронного письма, но встроенное изображение отображается в виде красной буквы "X". Ссылка на C19 - «Image.png» (это имя файла постоянно изменяется в зависимости от других данных) и имя файла.

Первые 2 макроса сохраняют файл в папке загрузок, а третий макрос в настоящее время выводится с красный "Х".

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

Проблема связана с оператором 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

Answer 2

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