vba - 在邮件正文中发送图表

Question

我正在尝试修改 Ron de Bruin 的代码以在邮件正文中发送图表。

我导出图表并将其保存为 PNG 图像，然后修改 HTML 代码以将其添加到消息中。

代码应该在服务器上运行并向我工作场所的人员发送邮件。

当使用 MailItem.Display 并在我的消息出现时手动单击“发送”时，一切正常。
当我尝试使用 MailItem.Send 时，我在邮件正文中看到一个图标，就像它试图附加找不到的图像一样。

当我通过服务器帐户从服务器发送该邮件时，图表会正确显示。
当我尝试在“本地”计算机上发送它时，它不起作用。

Sub wyslij()

    NameOfThisFile = ActiveWorkbook.Name
    
    Dim rng As Range
    Dim dataminus1, dataminus2 As Date
    Dim olApp As Outlook.Application
    Set olApp = CreateObject("Outlook.Application")
    
    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)
    
    Set rng = Nothing
    Set rng = Sheets(2).Range("E1:P13")
    
    olMail.To = "xxx@xxx" 
    olMail.CC = "xxxx@xxx"
    olMail.Subject = "xxxx"
    olMail.HTMLBody = RangetoHTML(rng)
    olMail.Display
    'olMail.Send
    
    'Delete file after sending a mail
    'Call DeleteFile(Path)
    
End Sub
    
Sub Save_ChartAsImage()
    
    ChartEx = False
    
    Dim cht As ChartObject
    
    For Each cht In ActiveSheet.ChartObjects
        If cht.TopLeftCell.Column = ChartCol And cht.TopLeftCell.Row = ChartRow Then
            ChartEx = True
            On erRROR GoTo Err_Chart
            cht.Chart.Export Filename:=ActiveWorkbook.Path & "\Chart.png", Filtername:="PNG"
        End If
    Next cht
    
Err_Chart:
    If Err <> 0 Then
        Debug.Print Err.Description
        Err.Clear
    End If
End Sub

Function RangetoHTML(rng As Range)

    ' Changed by Ron de Bruin 28-Oct-2006
    ' Working in Office 2000-2013
    
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        '.Cells(1).PasteSpecial xlPasteAll
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
    
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    
    'kopiujemy wykres z poprzedniego działu
    'Workbooks("WplatyFinal.xlsm").Activate
    Workbooks(NameOfThisFile).Activate
    Call Save_ChartAsImage
    
    TempWB.Activate
    TempWB.Sheets(1).Select
    
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
        
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    
    RangetoHTML = ts.readall
    ts.Close
    
    If ChartEx Then
        RangetoHTML = RangetoHTML & "<img src ='" & ActiveWorkbook.Path & "\Chart.png" & "'>"
    End If
        
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    
    'Close TempWB
    TempWB.Close savechanges:=False
    
    'Delete the htm file we used in this function
    Kill TempFile
    
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

我尝试在 Send 方法之后直接使用 Wait 函数。

Answer 1

让图像以内联方式显示当然是可能的。 HTML 中的 img src 必须引用带有图像标识符的 cid。下面的代码设置电子邮件并将所有图表对象作为内嵌图像添加到电子邮件中。

    Option Explicit
    
    Sub CreateEmail()
        Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
        Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
        Dim wb As Workbook
        Dim ws As Worksheet
        Dim olApp As Object
        Dim olMail As Object
        Dim msg As String
        Dim msgGreeting As String
        Dim msgPara1 As String
        Dim msgEnding As String
        Dim chrt As ChartObject
        Dim fname As String
        Dim ident As String
        Dim tempFiles As Collection
        Dim imgIdents As Collection
        Dim imgFile As Variant
        Dim attchmt As Object
        Dim oPa As Object
        Dim i As Integer
        
        '--- create the email body with HTML-formatted content
        msgGreeting = "<bold>Dear Sirs</bold>,<br><br>"
        msgPara1 = "<div>Here is the data you requested:</div>"
        msgEnding = "<br><br>Sincerely,<br>JimBob<br>"
        
        '--- build the other email body content
        Set wb = ActiveWorkbook
        Set ws = ActiveSheet
        msg = msgGreeting & msgPara1
        '--- loops and adds all charts found on the worksheet
        If ws.ChartObjects.Count > 0 Then
            Set tempFiles = New Collection
            Set imgIdents = New Collection
            For Each chrt In ws.ChartObjects
                fname = ""
                msg = msg & ChartToEmbeddedHTML(chrt, fname, ident) & "<br><br>"
                tempFiles.Add fname
                imgIdents.Add ident
            Next chrt
        End If
        msg = msg & msgEnding
        
        '--- create the mail item
        Set olApp = CreateObject("Outlook.Application")
        Set olMail = olApp.CreateItem(0)                'olMailItem=0
        With olMail
            .To = "yyy@zzzz.com"
            '.CC = "xxxx@xxx"
            .Subject = "xxxx"
            .bodyformat = 2        'olFormatHTML=2
            '--- each of the images is referenced as a filename, but each one must be
            '    individually added as an attachment, then the attachment properties
            '    set to show the attachment as "inline". Because the image will be
            '    inlined, we'll use the "ident" as the reference (internal to the
            '    message body HTML)
            If (Not tempFiles Is Nothing) Then
                For i = 1 To tempFiles.Count
                    Set attchmt = .attachments.Add(tempFiles.Item(i))
                    Set oPa = attchmt.PropertyAccessor
                    oPa.SetProperty PR_ATTACH_MIME_TAG, "image/png"
                    oPa.SetProperty PR_ATTACH_CONTENT_ID, imgIdents.Item(i)
                Next i
            End If
            '--- the email item needs to be saved first
            .Save
            '--- now add the message contents
            .htmlbody = msg
            .display
        End With
        '--- delete the temp files now
        For Each imgFile In tempFiles
            Kill imgFile
        Next imgFile
        '--- clean up and get out
        Set tempFiles = Nothing
        Set imgIdents = Nothing
        Set attchmt = Nothing
        Set oPa = Nothing
        Set olMail = Nothing
        Set olApp = Nothing
        Set ws = Nothing
        Set wb = Nothing
    End Sub
    
    Private Function ChartToEmbeddedHTML(thisChart As ChartObject, _
                                 ByRef tmpFile As String, _
                                 ByRef ident As String) As String
        Dim html As String
        ident = RandomString(8)
        tmpFile = thisChart.Parent.Parent.Path & "\" & ident & ".png"
        
        thisChart.Activate
        thisChart.Chart.Export Filename:=tmpFile, Filtername:="png"
        html = "<img alt='Excel Chart' src='cid:" & ident & "'></img>"
        ChartToEmbeddedHTML = html
    End Function
    
    Private Function RandomString(strlen As Integer) As String
        Dim i As Integer, iTemp As Integer, bOK As Boolean, strTemp As String
        '48-57 = 0 To 9, 65-90 = A To Z, 97-122 = a To z
        'amend For other characters If required
        For i = 1 To strlen
            Do
                iTemp = Int((122 - 48 + 1) * Rnd + 48)
                Select Case iTemp
                Case 48 To 57, 65 To 90, 97 To 122: bOK = True
                Case Else: bOK = False
                End Select
            Loop Until bOK = True
            bOK = False
            strTemp = strTemp & Chr(iTemp)
        Next i
        RandomString = strTemp
    End Function