как использовать средство доступа к свойству при встраивании изображения из временного файла в электронное письмо

Question

У меня есть макрос, который создает изображение из диапазона Excel и встраивает его в электронное письмо Outlook для каждого элемента в списке (новое изображение и электронное письмо для ~ 350 получателей).

Это хорошо работает для получателей.с рабочим столом outlook с изображением, отображаемым в теле письма, но изображение отображается в виде вложения для gmail и некоторых других почтовых клиентов и исчезает вместе для outlook mobile, что является проблемой.

некоторые поиски в Google сказали мне, что мне нужно использовать оценщик свойств, но у меня возникают трудности с изменением кода, который я нашел в Интернете, чтобы заставить его работать.надеясь, что кто-то увидит мою ошибку:

код

Sub Create_Emails()

    Dim r, tech_cnt As Integer
    Dim wk_date As Date
    Dim Email_Subject_Day As String
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    Dim body_text, tech_str, month_text As String
    Dim fldName As String

    Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"

     ' attach file

    Sheets("TM Weekly Data").Activate
    wk_date = Range("AK1")

        If Day(wk_date) = 1 Or Day(wk_date) = 21 Or Day(wk_date) = 31 Then
        Email_Subject_Day = Day(wk_date) & "st"
        ElseIf Day(wk_date) = 2 Or Day(wk_date) = 22 Then
        Email_Subject_Day = Day(wk_date) & "nd"
        ElseIf Day(wk_date) = 3 Or Day(wk_date) = 23 Then
        Email_Subject_Day = Day(wk_date) & "rd"
        Else
        Email_Subject_Day = Day(wk_date) & "th"
        End If


    r = 0

    ' Check the week is not blank and matches the most recent week, copy ID# to pic data


    Do While Range("AF4").Offset(r, 0) <> ""

        If Range("AF4").Offset(r, 0) = wk_date Then

            Range("AF4").Offset(r, 1).Copy
            Worksheets("PIC").Select
            Range("T2").PasteSpecial Paste:=xlPasteValues

            Application.CutCopyMode = False

            ' Set the range to turn into a picture

            Set xRg = Worksheets("PIC").Range("B4:P15").SpecialCells(xlCellTypeVisible)

            With Application
                .EnableEvents = False
                .ScreenUpdating = False

            End With


        Set xOutApp = CreateObject("outlook.application")
        Set xOutMail = xOutApp.CreateItem(olMailItem)

        Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")

        TempFilePath = Environ$("temp") & "\"

              Set colAttach = xOutMail.Attachments
              Set l_Attach = colAttach.Add(TempFilePath & "DashboardFile.jpg")



        xHTMLBody = "<span LANG=EN>" _
                & "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
                & "<p>Dear " + Worksheets("PIC").Range("T6") + ",</p></p></p>" _
                & "<p>Please find attached the scorecard results for " + Worksheets("PIC").Range("T3") + ":</p></p>" _
                & "<br>" _
                & "<img src='cid:DashboardFile.jpg'>" + ",</p></p></p>" _
                & "<br>This mailbox is not monitored, if you have any questions please discuss with your Manager </font></span>"

                objOutlookMsg.PropertyAccessor.SetProperty "http:// schemas.microsoft.com/mapi/proptag/0x370E001E", "image/jpeg"
                objOutlookMsg.PropertyAccessor.SetProperty "http:// schemas.microsoft.com/mapi/proptag/0x3712001E", "myident"
                objOutlookMsg.PropertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B", True

        With xOutMail
            .Subject = "Weekly Scorecard Results " & Email_Subject_Day & " " & MonthName(Month(wk_date))
            .HTMLBody = xHTMLBody
            .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
            .To = Worksheets("PIC").Range("T7")
            .CC = Worksheets("PIC").Range("T9")
            .Display
            .Send



        End With



    End If

    r = r + 1
    Sheets("TM Weekly Data").Activate
    Loop


End Sub

Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub