使用VBA从Excel到Outlook并使用CID将多个图像嵌入到电子邮件中

Question

我正在尝试将多个图形（作为PNG）从Excel VBA宏嵌入到Outlook中。 然而，图像嵌入，并不是所有8张图像，而是第一张重复8次。

Sub Test()
    Dim sheetNumber, size, i As Integer
    Dim chartNames(), FNames() As String
    Dim objChrt As ChartObject
    Dim myChart As Chart


    'Activate Charts Sheet
    Sheets("GRAFICAS").Activate
    'Calculate Number of Charts in Sheet
    chartNumber = ActiveSheet.ChartObjects.Count
    'Redimension Arrays to fit all Chart Export Names
    ReDim chartNames(chartNumber)
    ReDim FNames(chartNumber)
    'Loops through all the charts in the GRAFICAS sheet
    For i = 1 To chartNumber
        'Select chart with index i
        Set objChrt = ActiveSheet.ChartObjects(i)
        Set myChart = objChrt.Chart
        'Generate a name for the chart
        chartNames(i) = "myChart" & i & ".png"

        On Error Resume Next
        Kill ThisWorkbook.Path & "\" & chartNames(i)
        On Error GoTo 0
        'Export Chart
        myChart.Export Filename:=Environ$("TEMP") & "\" & chartNames(i), Filtername:="PNG"
        'Save path to exported chart
        FNames(i) = Environ$("TEMP") & "\" & chartNames(i)
    Next i
   'Declare the Object variables for Outlook.
    Dim objOutlook As Object
    'Verify Outlook is open.
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    'If Outlook is not open, end the Sub.
    If objOutlook Is Nothing Then
        Err.Clear
         MsgBox _
        "Cannot continue, Outlook is not open.", , _
        "Please open Outlook and try again."
        Exit Sub
    'Outlook is determined to be open, so OK to proceed.
    Else
        'Establish an Object variable for a mailitem.
        Dim objMailItem As Object
        Set objMailItem = objOutlook.CreateItem(0)
        'Build the mailitem.
        Dim NewBody As String
            On Error Resume Next
            With objMailItem
                .To = "dummy@test.com"
                .Subject = "Testing Lesson 31 email code"
                .Importance = 1 'Sets it as Normal importance (Low = 0 and High = 2)
                'Change the Display command to Send without reviewing the email.
               ' .Display
            End With
           For i = 1 To chartNumber
               objMailItem.Attachments.Add FNames(i)
               'Put together the HTML to embed
                NewBody = NewBody + HTMLcode & "<div align=center>" & "<IMG src=cid: myChart" & i & ".png></img>" & "</div>"
            Next
            MsgBox NewBody
               'Set the HTML body
                objMailItem.HTMLBody = NewBody
                'Display email before sending
                objMailItem.Display
    'Close the If block.
    End If
        Kill Fname
End Sub

MsgBox NewBody输出：

，最终的电子邮件如下：

它应该显示所有图表低于另一个图表，但它只需要myChart1.png并重复8次，尽管NewBody的输出。

我做错了什么？我正在使用Outlook 2013和Excel 2013

更新：我添加了另一张图片，在这种情况下，似乎重复了我添加了9次的最后一张图片（与附加图片的数量相同）。我猜这是cid的一个问题，也许ID不是唯一的？

Answer 1

您必须在附件上相应地设置PR_ATTACH_CONTENT_ID属性以匹配cid属性的值：

Set attach = objMailItem.Attachments.Add(FNames(i))
'Put together the HTML to embed
Dim cid
cid = "myChart" & i & ".png"
NewBody = NewBody + HTMLcode & "<div align=center>" & "<IMG src=cid:" & cid & "</img>" & "</div><br><br>"
   Call attach.PropertyAccessor.SetProperty("http://schemas.microsoft.com/mapi/proptag/0x3712001F", cid)