在邮件正文中发送图表
我试图修改Ron de Bruinsmacros在邮件正文中发送图表。 首先，我导出图表并将其保存为PNG图像，然后修改HTML代码以将其添加到消息中。 macros应运行在服务器上，并发送邮件给其他在我工作场所工作的人。 当我使用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函数，但是可悲的是它没有帮助。
让图像显示为内联是肯定可能的。 HTML中的img src必须使用图像的标识符引用cid 。 下面的代码设置电子邮件，并将所有图表对象作为内嵌图像添加到电子邮件。
选项显式
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