在邮件正文中发送图表

Question

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

\n

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

\n

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

\n

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

\n

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

\n

Sub wyslij()\n\n    NameOfThisFile = ActiveWorkbook.Name\n    \n    Dim rng As Range\n    Dim dataminus1, dataminus2 As Date\n    Dim olApp As Outlook.Application\n    Set olApp = CreateObject("Outlook.Application")\n    \n    Dim olMail As Outlook.MailItem\n    Set olMail = olApp.CreateItem(olMailItem)\n    \n    Set rng = Nothing\n    Set rng = Sheets(2).Range("E1:P13")\n    \n    olMail.To = "xxx@xxx" \n    olMail.CC = "xxxx@xxx"\n    olMail.Subject = "xxxx"\n    olMail.HTMLBody = RangetoHTML(rng)\n    olMail.Display\n    \'olMail.Send\n    \n    \'Delete file after sending a mail\n    \'Call DeleteFile(Path)\n    \nEnd Sub\n    \nSub Save_ChartAsImage()\n    \n    ChartEx = False\n    \n    Dim cht As ChartObject\n    \n    For Each cht In ActiveSheet.ChartObjects\n        If cht.TopLeftCell.Column = ChartCol And cht.TopLeftCell.Row = ChartRow Then\n            ChartEx = True\n            On erRROR GoTo Err_Chart\n            cht.Chart.Export Filename:=ActiveWorkbook.Path & "\\Chart.png", Filtername:="PNG"\n        End If\n    Next cht\n    \nErr_Chart:\n    If Err <> 0 Then\n        Debug.Print Err.Description\n        Err.Clear\n    End If\nEnd Sub\n\nFunction RangetoHTML(rng As Range)\n\n    \' Changed by Ron de Bruin 28-Oct-2006\n    \' Working in Office 2000-2013\n    \n    Dim fso As Object\n    Dim ts As Object\n    Dim TempFile As String\n    Dim TempWB As Workbook\n    \n    TempFile = Environ$("temp") & "\\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"\n    \n    \'Copy the range and create a new workbook to past the data in\n    rng.Copy\n    Set TempWB = Workbooks.Add(1)\n    \n    With TempWB.Sheets(1)\n        .Cells(1).PasteSpecial Paste:=8\n        .Cells(1).PasteSpecial xlPasteValues, , False, False\n        \'.Cells(1).PasteSpecial xlPasteAll\n        .Cells(1).PasteSpecial xlPasteFormats, , False, False\n    \n        .Cells(1).Select\n        Application.CutCopyMode = False\n        On Error Resume Next\n        .DrawingObjects.Visible = True\n        .DrawingObjects.Delete\n        On Error GoTo 0\n    End With\n    \n    \'kopiujemy wykres z poprzedniego dzia\xc5\x82u\n    \'Workbooks("WplatyFinal.xlsm").Activate\n    Workbooks(NameOfThisFile).Activate\n    Call Save_ChartAsImage\n    \n    TempWB.Activate\n    TempWB.Sheets(1).Select\n    \n    \'Publish the sheet to a htm file\n    With TempWB.PublishObjects.Add( _\n         SourceType:=xlSourceRange, _\n         Filename:=TempFile, _\n         Sheet:=TempWB.Sheets(1).Name, _\n         Source:=TempWB.Sheets(1).UsedRange.Address, _\n         HtmlType:=xlHtmlStatic)\n        .Publish (True)\n    End With\n    \n    \'Read all data from the htm file into RangetoHTML\n    Set fso = CreateObject("Scripting.FileSystemObject")\n        \n    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)\n    \n    RangetoHTML = ts.readall\n    ts.Close\n    \n    If ChartEx Then\n        RangetoHTML = RangetoHTML & "<img src =\'" & ActiveWorkbook.Path & "\\Chart.png" & "\'>"\n    End If\n        \n    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _\n                          "align=left x:publishsource=")\n    \n    \'Close TempWB\n    TempWB.Close savechanges:=False\n    \n    \'Delete the htm file we used in this function\n    Kill TempFile\n    \n    Set ts = Nothing\n    Set fso = Nothing\n    Set TempWB = Nothing\nEnd Function\n

\n

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

\n

Answer 1

让图像以内联方式显示当然是可能的。HTMLimg 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