我正在尝试修改 @PeterT 的一些代码，它将图表作为图像添加到 Outlook 电子邮件中。他的代码非常适合将图表添加到电子邮件中，并且速度超级快（谢谢@PeterT！）
我正在尝试将 Excel 命名范围（命名范围的范围每个月都会变化）添加到电子邮件正文中，作为*图表之前的图像。到目前为止，我所做的尝试确实将图像捕获到剪贴板，但随后我必须手动将其粘贴到图表上方的电子邮件正文。
理想情况下，我想将范围图像保存到临时文件名，就像宏/函数对图表所做的那样，然后让宏立即将范围和图表插入电子邮件正文中。
谢谢， 唐
@PeterT 的代码稍作修改即可捕获 3 个特定图表与 ActiveSheet 上的所有图表：
Option Explicit
'https://stackoverflow.com/questions/34161736/sending-a-chart-in-mail-body
'Super fast at adding the Charts to an email
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
Dim chartNumbers As Variant
Dim ii As Long
Dim myChartObj As ChartObject
Dim rng As Range
Dim imgFileName As String
'--- create the email body with HTML-formatted content
msgGreeting = "<bold>Team</bold>,<br><br>"
msgPara1 = "<div>Some Text1</div><br>" & _
"<div><bold>Some Text2</bold><br>" & _
"(Some Text3)</div><br><br>"
msgEnding = "<br><br>Thanks,<br>MyName<br>MyTitle<br>MyPhoneNumber<br>"
'--- build the other email body content
Set wb = ActiveWorkbook
Set ws = ActiveSheet
msg = msgGreeting & msgPara1
'--- This captures a picture of the Range, but needs to be manually pasted to the email
' Set the range you want to copy
Set rng = Worksheets("Daily Average").Range("DailyAverage")
' Copy the range as an image
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'--- loops and adds all charts found on the worksheet
If ws.ChartObjects.Count > 0 Then
Set tempFiles = New Collection
Set imgIdents = New Collection
'--- Use this section to loop thru all the Chart Objects on the ActiveSheet
' instead of using the array of specific Charts below
' For Each chrt In ws.ChartObjects
' fname = ""
' msg = msg & ChartToEmbeddedHTML(chrt, fname, ident) & "<br><br>"
' tempFiles.Add fname
' imgIdents.Add ident
' Next chrt
' Define the array of chart numbers you want to process
'Added this section FROM HERE.....
chartNumbers = Array(10, 15, 16)
For ii = LBound(chartNumbers) To UBound(chartNumbers)
Set myChartObj = ws.ChartObjects("Chart " & chartNumbers(ii))
'--- This With section resizes the Charts on the ActiveSheet
' With myChartObj
' .Height = 350
' .Width = 600
' End With
fname = ""
msg = msg & ChartToEmbeddedHTML(myChartObj, fname, ident) & "<br><br>"
tempFiles.Add fname
imgIdents.Add ident
Next ii
'.....TO HERE and commented out the previous 6 lines to loop thru all the Chart Objects on the ActiveSheet
End If
msg = msg & msgEnding
'--- create the mail item
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0) 'olMailItem=0
With olMail
.To = ThisWorkbook.Sheets("Signature").Range("D2").Value ' "[email protected]"
.CC = ThisWorkbook.Sheets("Signature").Range("D4").Value ' "xxxx@xxx"
.Subject = ThisWorkbook.Sheets("Signature").Range("D7").Value & " - " & Format(Date, "dd-mmm-yyyy") ' "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
'''--- Not finding the right place for this
''' Paste the image into the email body
'olMail.GetInspector.WordEditor.Range.Paste
.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 rng = 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
我尝试的是将此代码插入到宏内的各个位置，但没有任何运气......基本上它只是插入图表并“忽略”Range.Paste 行。
'''--- Not finding the right place for this
''' Paste the image into the email body
'olMail.GetInspector.WordEditor.Range.Paste
这是使用不同方法添加图像的示例。这对我来说比使用“cid+attachment”方法更干净。
Option Explicit
Sub Tester()
Dim sht As Worksheet, html As String, olApp As Object, olMail As Object
Set sht = ThisWorkbook.Worksheets("Sheet2") 'for example
html = "<p>Header here</p>"
html = html & ToImageTag(sht.Range("B2:H8")) & "<br>"
html = html & "<p>Footer here</p>"
html = html & ToImageTag(sht.ChartObjects("chart1").Chart) & "<br>"
html = html & "<p>Footer2 here</p>"
html = html & ToImageTag(sht.Range("C18:F31")) & "<br>"
html = html & "<p>Footer3 here</p>"
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.CreateItem(0) 'olMailItem=0
With olMail
.BodyFormat = 2 'olFormatHTML=2
.HTMLBody = html
.display
End With
End Sub
'Convert a range or chart an <img> tag for HTML,with image content encoded as B64
Function ToImageTag(obj As Object) As String
Dim b64 As String
If TypeName(obj) = "Range" Then
b64 = RangeToB64(obj)
Else 'is a chart
b64 = ChartToB64(obj)
End If
ToImageTag = "<img src='data:image/png;base64," & b64 & "'>"
End Function
'Convert a Range to a B64 string (via exported chart image)
Function RangeToB64(rng As Range) As String
Dim cob, sc, i As Long
rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set cob = rng.Parent.ChartObjects.Add(100, 100, 200, 200)
Set sc = cob.Chart.SeriesCollection 'remove any series which may have been auto-added...
Do While sc.Count > 0
sc(1).Delete
Loop
With cob
.ShapeRange.line.Visible = msoFalse '<<< remove chart border
.Height = rng.Height
.Width = rng.Width
Do
.Chart.Paste
DoEvents
i = i + 1
Loop While i < 5 And .Chart.Shapes.Count = 0 'in case paste failed try 5 times...
RangeToB64 = ChartToB64(.Chart)
.Delete
End With
End Function
'Convert chart to b64 string via exported temp file
Function ChartToB64(cht As Chart)
Dim sPath As String
sPath = TempPath
cht.Export FileName:=sPath, Filtername:="PNG"
ChartToB64 = EncodeBase64(sPath)
Kill sPath
End Function
'get a B64-encoded string from a file
Function EncodeBase64(filePath As String) As String
Dim bytes, b64
With CreateObject("ADODB.Stream")
.Open
.Type = 1 'ADODB.adTypeBinary
.LoadFromFile filePath
bytes = .Read
.Close
End With
With CreateObject("MSXML2.DOMDocument").createElement("b64")
.DataType = "bin.base64"
.nodeTypedValue = bytes
EncodeBase64 = Replace(.text, vbLf, "")
End With
End Function
'Return a temporary file path
Function TempPath() As String
With CreateObject("scripting.filesystemobject")
TempPath = .GetSpecialFolder(2) & "\tmp" & CLng(Rnd() * 1000000000#)
End With
End Function