将临时文件中的图像嵌入到电子邮件中时如何使用属性访问器

Question

我有一个宏，可以在excel中生成一系列图像，并将其嵌入到列表中每个项目的Outlook电子邮件中（新图像和约350个收件人的电子邮件）

这对于使用Outlook桌面且图片显示在电子邮件正文中的收件人来说效果很好，但是该图像显示为gmail和其他一些电子邮件客户端的附件，对于Outlook Mobile而言，它们一起消失了。

一些谷歌搜索告诉我我需要使用属性评估器，但是我很难修改我在网上找到的代码以使其正常工作。希望有人可以看到我的错误：

代码

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