我一直在使用这个网站，并试图在网站和其他地方的信息生存。但是，这一次，我放弃了：我无法找到解决方案/答案。
我要做的是从同一个Excel文件中发送图表和数据透视表，但电子邮件正文中的相同表格不同。
我有必要的代码来单独执行此操作，但我无法将两个代码组合在一起，以便在同一封电子邮件中同时包含图表和数据透视表。 （请注意，我不确定中间部分是否有任何作用，但我还没有过滤/清理过代码，我只想让它先工作然后我会删除不必要的行）
以下是我的两个代码：
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>Hello</bold>,<br><br>"
msgPara1 = "<div>Please find your REPORT below:</div>"
msgEnding = "<br><br>Best regards,"
'--- build the other email body content
Set wb = ActiveWorkbook
Set ws = Sheets("Charts")
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 = "INSERTEMAIL"
'.CC = "xxxx@xxx"
.Subject = "REPORT"
.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
Sub TablesEmail()
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim rng As Range, rng2 As Range, rng3 As Range, rng4 As Range, rng5 As Range
Dim outApp As Object
Dim outMail As Object
Set rng = Nothing
On Error Resume Next
' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").PivotTables(2).TableRange1
Set rng2 = Sheets("Sheet2").PivotTables(2).TableRange1
Set rng3 = Sheets("Sheet3").PivotTables(2).TableRange1
Set rng4 = Sheets("Sheet4").PivotTables(2).TableRange1
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
On Error Resume Next
With outMail
.To = "1234556676578---Trial"
.CC = ""
.BCC = ""
.Subject = "report"
.HTMLBody = RangetoHTML(rng) & RangetoHTML(rng2) & RangetoHTML(rng3) & RangetoHTML(rng4)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set outMail = Nothing
Set outApp = Nothing
End Sub
Function RangetoHTML(PT As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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
PT.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.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
'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
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