I am having considerable difficulty figuring this one out. I can paste a range as HTML without issues, but in some communications we want to past the range as a picture instead. I can create a range and save it as a picture, but I cannot figure out how to past the picture into Outlook after it is created.
If you are just looking for code that will copy a range and paste it into Outlook, this works great. All of the email data is referencing cells on a tab called Mail, so you can simply copy and paste the Mail tab and the macro into any workbook and add email automation by editing the fields on the mail tab and not changing the macro. If you use this code, make sure to reference Microsoft Outlook x.x Object Library (In VBA Window: Tools – References – Microsoft Outlook x.x Object Library).
I need to take this one step further and be able to turn the range into a picture and paste it into the email. I can attach it, but I cannot insert it into the body, which is what I need. I have looked at several examples, including those on Ron DeBruins website, but I have not been able to get any of them to work. I am running Windows 7 x64 With Office 2010 x64.
Here is the code I am running to paste a range.
Option Explicit Sub Mail_AS_Range() ' Working in Office 2010-2013 Dim OutApp As Outlook.Application Dim OutMail As Outlook.MailItem Dim strbody As String On Error Resume Next Dim sh As Worksheet Set sh = Sheets("Mail") strbody = sh.Range("C9").Value Sheets(sh.Range("C11").Value).Select ActiveWorkbook.Save Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) With OutMail .SentOnBehalfOfName = sh.Range("C4") 'This allows us to send from an alternate email address .Display 'Alternate send address will not work if we do not display the email first. 'I dont know why but this step is a MUST .To = sh.Range("C5") .CC = sh.Range("C6") .BCC = sh.Range("C7") .Subject = sh.Range("C8").Value .HTMLBody = "<br>" & strbody & fncRangeToHtml(sh.Range("C13").Value, sh.Range("C14").Value) & .HTMLBody ' This is where the body of the email is pulled together. ' <br> is an HTML tag to turn the text into HTML ' strbody is your text from cell C9 on the mail tab ' fncRangetoHtml is converting the range you specified into HTML ' .HTMLBody inserts your email signature .Attachments.Add sh.Range("C10").Value '.Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing End Sub Private Function fncRangeToHtml( _ strWorksheetName As String, _ strRangeAddress As String) As String ' This is creating a private function to make the range specified in the Mail macro into HTML Dim objFilesytem As Object, objTextstream As Object, objShape As Shape Dim strFilename As String, strTempText As String Dim blnRangeContainsShapes As Boolean strFilename = Environ$("temp") & "\" & _ Format(Now, "dd-mm-yy_h-mm-ss") & ".htm" ThisWorkbook.PublishObjects.Add( _ SourceType:=xlSourceRange, _ Filename:=strFilename, _ Sheet:=strWorksheetName, _ Source:=strRangeAddress, _ HtmlType:=xlHtmlStatic).Publish True Set objFilesytem = CreateObject("Scripting.FileSystemObject") Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2) strTempText = objTextstream.ReadAll objTextstream.Close strTempText = Replace(strTempText, "align=center x:publishsource=", "align=left x:publishsource=") For Each objShape In Worksheets(strWorksheetName).Shapes If Not Intersect(objShape.TopLeftCell, Worksheets( _ strWorksheetName).Range(strRangeAddress)) Is Nothing Then blnRangeContainsShapes = True Exit For End If Next If blnRangeContainsShapes Then strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName)) fncRangeToHtml = strTempText Set objTextstream = Nothing Set objFilesytem = Nothing Kill strFilename End Function Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String Const HTM_START = "<link rel=File-List href=" Const HTM_END = "/filelist.xml" Dim strTemp As String Dim lngPathLeft As Long lngPathLeft = InStr(1, strTempText, HTM_START) strTemp = Mid$(strTempText, lngPathLeft, InStr(lngPathLeft, strTempText, ">") - lngPathLeft) strTemp = Replace(strTemp, HTM_START & Chr$(34), "") strTemp = Replace(strTemp, HTM_END & Chr$(34), "") strTemp = strTemp & "/" strTempText = Replace(strTempText, strTemp, Environ$("temp") & "\" & strTemp) fncConvertPictureToMail = strTempText End Function
Any suggestions would be appreciated. Thanks!
Thank you to BP_ who directed me to a link, which answered my question. Here is my code after modifying for my application.
This allows me to set all the variables within a tab in Excel and not edit the query itself. I use this method because some folks on my team are not comfortable editing VBA.
Sub Mail_W_Pic() Dim TempFilePath As String Dim OutApp As Outlook.Application Dim OutMail As Outlook.MailItem Dim strbody As String Dim width As String Dim height As String On Error Resume Next Dim sh As Worksheet Set sh = Sheets("Mail") strbody = sh.Range("C9").Value Sheets(sh.Range("C11").Value).Select width = (sh.Range("C15").Value) height = (sh.Range("C16").Value) 'Create a new Microsoft Outlook session Set OutApp = CreateObject("outlook.application") 'create a new message Set OutMail = OutApp.CreateItem(olMailItem) With OutMail .SentOnBehalfOfName = sh.Range("C4") .Display .Subject = sh.Range("C8").Value .To = sh.Range("C5") .CC = sh.Range("C6") .BCC = sh.Range("C7") 'first we create the image as a JPG file Call createJpg(sh.Range("C13").Value, sh.Range("C14").Value, "DashboardFile") 'we attached the embedded image with a Position at 0 (makes the attachment hidden) TempFilePath = Environ$("temp") & "\" .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0 'Then we add an html <img src=''> link to this image 'Note than you can customize width and height - not mandatory .HTMLBody = "<br>" & strbody & "<br><br>" _ & "<img src='cid:DashboardFile.jpg'" & "width=width height=heigth><br><br>" _ & "<br>Best Regards,<br>Ed</font></span>" & .HTMLBody .Display '.Send End With Set sh = Nothing End Sub Sub createJpg(Namesheet As String, nameRange As String, nameFile As String) ThisWorkbook.Activate Worksheets(Namesheet).Activate Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange) Plage.CopyPicture With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.width, Plage.height) .Activate .Chart.Paste .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG" End With Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete Set Plage = Nothing End Sub