Copy Excel Worksheet Range and Paste into Outlook as a picture

Question

Pretty simple and straight forward. I am looking to copy a range in a worksheet, open a new email to outlook and paste the range as an image. The following code is what I currently have. Despite my efforts, I have been unable to paste as a photo.

Sub CreateMail()

Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range

Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)

With Sheets("Hourly Labor Model")
    Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))

End With
rngBody.Copy

With objMail
    .To = "user@useremail.com"
    .Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " @ " & Format(Time(), "hh:mm:ss")
    .display


End With
SendKeys "^({v})", True

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

End Sub

Please and thank you in advance.

Possible duplicate of [Excel 2010 Paste Range and Picture into Outlook](http://stackoverflow.com/questions/27042842/excel-2010-paste-range-and-picture-into-outlook) or [this one](http://stackoverflow.com/questions/29092999/pasting-an-excel-range-into-an-email-as-a-picture). — BruceWayne, Jan 04 '16 at 20:47
If you are looking to do additional work with Excel and Outlook mail items, this site can be very useful http://www.rondebruin.nl/win/s1/outlook/mail.htm Specifically for your question, Ron de Bruin has this page http://www.rondebruin.nl/win/s1/outlook/amail7.htm — Dan, Jan 04 '16 at 21:41

score 1 · Answer 1 · edited May 23 '17 at 11:44

Based on this thread, I think the below would work:

Sub CreateMail()

Dim objOutlook As Object
Dim objMail As Object
Dim rngTo As Range
Dim rngBody As Range
Dim outMail As Outlook.MailItem 'new

Set objOutlook = CreateObject("Outlook.Application")

Set objMail = objOutlook.CreateItem(0)
Set outMail = objOutlook.CreateItem(olMailItem)


With Sheets("Hourly Labor Model")
    Set rngBody = .Range(.Range("A6"), .Range("AA99").End(xlDown))

End With
rngBody.Copy

With objMail
    .To = "user@useremail.com"
    .Subject = "Hourly Dashboard- " & Sheets("Graphs").Range("AA1") & " on " & Format(Now(), "mm/dd/yyyy") & " @ " & Format(Time(), "hh:mm:ss")
    .Display
'outMail.Display
    Dim wordDoc As Word.Document
    Set wordDoc = .GetInspector.WordEditor ' or use outMail instead of with()
    wordDoc.Range.PasteandFormat wdChartPicture

End With
SendKeys "^({v})", True

On Error GoTo 0
Set outMail = Nothing
Set OutApp = Nothing

End Sub

Copy Excel Worksheet Range and Paste into Outlook as a picture

1 Answers1