Excel – Pasting an Excel range into an email as a picture

excelvba

I'm creating an Outlook email from Excel (Office 2013). I want to paste a range of cells (C3:S52) into the email as a picture.

Below is the code I have so far. Where am I going wrong?

 Sub Button193_Click()
 '
 ' Button193_Click Macro
 '

 '
 ActiveWindow.ScrollColumn = 2
 ActiveWindow.ScrollColumn = 1
 Range("C3:S52").Select
 Selection.Copy
 End Sub
 Sub CreateMail()

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

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

 With ActiveSheet
 Set rngTo = .Range("E55")
 Set rngSubject = .Range("E56")
 Set rngBody = .Range("E57")
 End With

 With objMail
 .To = rngTo.Value
 .Subject = rngSubject.Value
 .Body = rngBody.Value
 .Display 'Instead of .Display, you can use .Send to send the email _
 or .Save to save a copy in the drafts folder
 End With

 Set objOutlook = Nothing
 Set objMail = Nothing
 Set rngTo = Nothing
 Set rngSubject = Nothing
 Set rngBody = Nothing
 Set rngAttach = Nothing

 End Sub
 Sub Button235_Click()
 '
 ' Button235_Click Macro
 '

 '
 ActiveWindow.ScrollColumn = 2
 ActiveWindow.ScrollColumn = 1
 Range("A1:M27").Select
 Selection.Copy
 End Sub
 Sub RunThemAll()

 Application.Run "Button193_Click"

 Application.Run "CreateMail"

 End Sub 

Best Solution

Here's a worked example, tested in Office 2010:

enter image description here

'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy

'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor

'To paste as picture
wordDoc.Range.PasteAndFormat wdChartPicture

'To paste as a table
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False

Result:

enter image description here

In the code above I used early binding to have access to autocomplete; to use this code you need to set references to the Microsoft Outlook and Microsoft Word object libraries: Tools > References... > set checkmarks like this:

enter image description here

Alternatively, you can forget about the references and use late binding, declaring all the Outlook and Word objects As Object instead of As Outlook.Application and As Word.Document etc.


Apparently you're having trouble implementing the above; the range pastes as a table rather than a picture in your email message. I have no explanation for why that would happen.

An alternative is then to paste as an image in Excel, and then cut and paste that image into your e-mail:

'Copy range of interest
Dim r As Range
Set r = Range("B2:D5")
r.Copy

'Paste as picture in sheet and cut immediately
Dim p As Picture
Set p = ActiveSheet.Pictures.Paste
p.Cut

'Open a new mail item
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)

'Get its Word editor
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor

'Paste picture
wordDoc.Range.Paste

As pointed out by WizzleWuzzle, there is also the option of using PasteSpecial instead of PasteAndFormat or Paste...

wordDoc.Range.PasteSpecial , , , , wdPasteBitmap

... but for some reason, the resulting image doesn't render as well. See how the lower table is kind of blurry:

enter image description here