Solved Pasting range into outlook as picture

September 22, 2018 at 08:23:56
Specs: Windows 7
I have this code that I found on the web a long time ago (thank you Ron de Bruin) and have been using in many projects. I now need to modify so that it pastes the range in the outlook email as a picture. I am not an expert at all I just have been modifying VBA code to fit my projects. There is a lot of samples on how to paste as a picture but I can't seem to make it work and still keep the functionality of what I currently have. The code I currently have works perfectly but pastes the data as a table in Outlook (the default).

Sub Email_Options()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("Closing Costs").Range("B50:E73")


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)
With OutMail
.Display
End With
Signature = OutMail.HTMLBody
StrBody = "Loan Options: "

With OutMail
.Subject = "Loan Options (loanDepot) "
.HTMLBody = "<BODY style=font-size:12.5pt;font-family:Calibri>" & "</p>" & 
StrBody & RangetoHTML(rng) & Signature
.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(rng As Range)
' By Ron de Bruin.
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 paste the data in
rng.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

message edited by mecerrato


See More: Pasting range into outlook as picture

Reply ↓  Report •

#1
September 24, 2018 at 05:31:51
Here is am example I have put together from various sites, it works, may not be the most graceful but it works....

The ExportRange sub repeats the file path, sheet name and range, you may wish to modify it so that you can pass these variables to it rather than having them in two sub routines.....

Hope this helps

Sub Email_Options()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Signature As String

Set rng = Nothing
' Only send the visible cells in the selection.

Set rng = Sheets("Closing Costs").Range("B50:E73")


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)
With OutMail
.Display
End With
Signature = OutMail.HTMLBody
StrBody = "Loan Options: "


ExportRange

With OutMail
.Attachments.Add "C:\export.jpg", olByValue, 0
.Subject = "Loan Options (loanDepot) "

.HTMLBody = .HTMLBody & StrBody & "
<B></B>
" _
                & "<img src='cid:export.jpg'" & "width='700' height='400'>
" _
                & "
</font></span>" & Signature

.Display
End With

On Error GoTo 0

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

Set OutMail = Nothing
Set OutApp = Nothing
End Sub


Sub ExportRange()

   Const FName          As String = "C:\export.jpg"
   Dim rng              As Range
   Dim shtTemp          As Worksheet
   Dim chtTemp          As Chart

   Application.ScreenUpdating = False
   Set rng = Worksheets("Closing Costs").Range("B50:E73")
   Set shtTemp = Worksheets.Add
   Charts.Add
   ActiveChart.Location Where:=xlLocationAsObject, Name:=shtTemp.Name
   Set chtTemp = ActiveChart
   rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
   chtTemp.Paste
   chtTemp.Export Filename:=FName
   Application.DisplayAlerts = False
   shtTemp.Delete
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True

End Sub


Reply ↓  Report •

#2
September 25, 2018 at 15:24:26
Thanks for the code, I was able to get it to work but the picture comes out quite distorted so it doesn't fit my application. I was hoping it would paste it as it does when you copy a range and open an email and right click paste as image, doing it this why keeps the look proportional.

Reply ↓  Report •

#3
September 27, 2018 at 01:16:20
✔ Best Answer
There is another way, but I currently don't have much time to play with it, have a go if you like.

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



Reply ↓  Report •
Related Solutions


Ask Question