Отправить Excel диапазон, включая график по электронной почте

Question

У меня возникают проблемы с изменением макроса, чтобы вместо этого скопировать выбранный диапазон данных и отправить его по электронной почте на определенный адрес.

Я начинаю с следующим рабочим кодом:

Sub Mail_Range() 
'Working in Excel 2000-2016 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
Dim Source As Range 
Dim Dest As Workbook 
Dim wb As Workbook 
Dim TempFilePath As String 
Dim TempFileName As String 
Dim FileExtStr As String 
Dim FileFormatNum As Long 
Dim OutApp As Object 
Dim OutMail As Object 

Set Source = Nothing 
On Error Resume Next 
Set Source = Range("A1:K50").SpecialCells(xlCellTypeVisible) 
On Error GoTo 0 

If Source Is Nothing Then 
    MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly 
    Exit Sub 
End If 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

Set wb = ActiveWorkbook 
Set Dest = Workbooks.Add(xlWBATWorksheet) 

Source.Copy 
With Dest.Sheets(1) 
    .Cells(1).PasteSpecial Paste:=8 
    .Cells(1).PasteSpecial Paste:=xlPasteValues 
    .Cells(1).PasteSpecial Paste:=xlPasteFormats 
    .Cells(1).Select 
    Application.CutCopyMode = False 
End With 

TempFilePath = Environ$("temp") & "\" 
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss") 

If Val(Application.Version) < 12 Then 
    'You use Excel 97-2003 
    FileExtStr = ".xls": FileFormatNum = -4143 
Else 
    'You use Excel 2007-2016 
    FileExtStr = ".xlsx": FileFormatNum = 51 
End If 

Set OutApp = CreateObject("Outlook.Application") 
Set OutMail = OutApp.CreateItem(0) 

With Dest 
    .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum 
    On Error Resume Next 
    With OutMail 
     .to = "ron@debruin.nl" 
     .CC = "" 
     .BCC = "" 
     .Subject = "This is the Subject line" 
     .Body = "Hi there" 
     .Attachments.Add Dest.FullName 
     'You can add other files also like this 
     '.Attachments.Add ("C:\test.txt") 
     .Send 'or use .Display 
    End With 
    On Error GoTo 0 
    .Close savechanges:=False 
End With 

Kill TempFilePath & TempFileName & FileExtStr 

Set OutMail = Nothing 
Set OutApp = Nothing 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 
End Sub 

Вопросов:

1) Как копировать любые диаграммы, которые находятся в определенном диапазоне?

2) Как поместить скопированный диапазон в область .Body?

Answer 1

Если у вас установлен полный Office, для этого вы можете использовать редактор Word в Outlook. Этот редактор Word может вставлять скопированные диапазоны Excel либо в виде связанных диапазонов Excel, либо в виде нескольких других объектов, которые могут быть указаны с помощью WdPasteDataType Enumeration.

Пример:

Имея активный Excel лист, как:

кодекса как это:

Sub emailer() 

'get Outlook Application 
Dim oOlApp As Object 
On Error Resume Next 
Set oOlApp = GetObject(, "Outlook.Application") 
On Error GoTo 0 
If oOlApp Is Nothing Then 
    Set oOlApp = CreateObject("Outlook.Application") 
End If 

olMailItem = 0 
Set oOlMItem = oOlApp.CreateItem(olMailItem) 

'get Excel cell range which shall be in the mail 
Set oWB = ActiveWorkbook 
Set oWS = ActiveWorkbook.Worksheets(1) 
Set oRange = oWS.Range("A1:H17") 
oRange.Copy ' Range is now in Clipboard 

With oOlMItem 

    .Display 

    .To = "email@email.com" 
    .Subject = "Subject" 

    Set oOlInsp = .GetInspector 
    Set oWdDoc = oOlInsp.WordEditor ' get Word Document from the MailBody 

    olFormatRichText = 3 
    .BodyFormat = olFormatRichText ' change to RichTextFormat 

    Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range 
    oWdRng.InsertBefore "This is before the Excel table." 
    oWdRng.InsertParagraphAfter 
    oWdRng.InsertParagraphAfter 

    Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range 

    'oWdRng.Paste ' paste Excel range from Clipboard as linked Excel range 

    wdInLine = 0 
    wdPasteEnhancedMetafile = 9 
    wdPasteOLEObject = 0 

    'paste Excel range from Clipboad as OLEObject 
    oWdRng.PasteSpecial Placement:=wdInLine, DataType:=wdPasteOLEObject 
    'paste Excel range from Clipboad as EnhancedMetafile 
    'oWdRng.PasteSpecial Placement:=wdInLine, DataType:=wdPasteEnhancedMetafile 

    oWdRng.InsertParagraphAfter 

    Set oWdRng = oWdDoc.Paragraphs(oWdDoc.Paragraphs.Count).Range 
    oWdRng.InsertBefore "This is after the Excel table." 


End With 

Application.CutCopyMode = False 

End Sub 

производит эту почту в Outlook: