Paste excel range into e-mail as JPEG (VBA)

[robovacuum_2]

Hi all,

I am trying to paste a range from excel - the range area includes both cells with data in them and a share price graph - into an automated e-mail as an image using VBA

Usually, I right click and paste as image

I have the following code, which is writing the e-mail and pasting the image below the text body, but unfortunately, the formatting is not legible when pasted as a cell range rather than image in outlook/email

Please see my current code below - appreciate any help that can be provided!

------------------------------------------------------------------------------------------

1) Pastes the link to the image but not the image itself

Sub SendEmail1()
'Generate e-mail with attachments
Dim Outapp As Object
Dim outmail As Object
Dim files As String
Dim main_body As String
Dim mess_body As String, StrFile As String, StrPath As String

main_body = Worksheets("BB (dynamic)").Range("B10").Value
StrPath = "c:\Users\Desktop\Today\"
Set Outapp = CreateObject("outlook.application")
Set outmail = Outapp.CreateItem(0)

With outmail
.To = Worksheets("BB (dynamic)").Range("C2").Value
.CC = Worksheets("BB (dynamic)").Range("C3").Value
.BCC = Worksheets("BB (dynamic)").Range("C4").Value
.Subject = Worksheets("BB (dynamic)").Range("C5").Value

.attachments.Add ("c:\Users\Desktop\TestImage.JPEG"), olbyvalue, 0
StrFile = Dir(StrPath & "*.*")
Do While Len(StrFile) > 0
.attachments.Add StrPath & StrFile
StrFile = Dir
Loop
.body = main_body _
& "<img src='c:\Users\Desktop\TestImage.JPEG'" & "width='814' height='33'><br>"

.display

End With
End Sub


2) Pastes the image in body (but not as JPEG)

With outmail

.To = Worksheets("Email").Range("C4").Value

.CC = Worksheets("Email").Range("C5").Value

.BCC = Worksheets("Email").Range("C6").Value

.Subject = Worksheets("Email").Range("C7").Value



StrFile = Dir(StrPath & "*.*")



Do While Len(StrFile) > 0

.attachments.Add StrPath & StrFile

StrFile = Dir

Loop



strfile1 = Dir(strpath1 & "*.*")



Do While Len(strfile1) > 0

.attachments.Add strpath1 & strfile1

strfile1 = Dir

Loop



.body = main_body & vbCrLf



Worksheets("Output").Range("B2:L46").Copy



Set vinspector = outmail.getinspector

Set weditor = vinspector.wordeditor



weditor.Application.Selection.Start = Len(.body)

weditor.Application.Selection.End = weditor.Application.Selection.Start



weditor.Application.Selection.Paste



.display



End With



End Sub

 

[mrshl9898]

Here's code I use, note the RangetoHTML function:

Sub exportdaily()

Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim rng As Range
Dim FName As String
Dim FPath As String
Dim OutlookApp As Object, OutlookMail As Object
Dim EmailSubject As String, EmailSignature As String
Dim Email_To As String, Email_CC As String, Email_BCC As String

    ActiveWorkbook.Save
    
    Set rng = Sheets(Dstr).Range("A1:G40").SpecialCells(xlCellTypeVisible)
    EmailSubject = "DPM " & Dstr
    DisplayEmail = True
    Email_To = "xxx"
    Email_CC = "xxx@xxx.com"
    Email_BCC = ""
    
    
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMail = OutlookApp.CreateItem(0)
    With OutlookMail

        .display
        .To = Email_To
        .CC = Email_CC
        .BCC = Email_BCC
        .Subject = EmailSubject
        .Attachments.Add (ActiveWorkbook.FullName)
        .HTMLBody = RangetoHTML(rng)


    End With

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ActiveWorkbook.Close

End Sub






Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    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 workbook to receive the data.
    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 an .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 the RangetoHTML subroutine.
    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.
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

 

[robovacuum_2]

Thanks so much - seems to paste everything perfectly (with respect to the cells and their current formatting), however, does not include the share price graph in the selected range of cells.

Do you have any suggestions here?

Greatly appreciate your help

 

[John_w]

Try this macro:

Public Sub Send_Outlook_Email()

    Dim OutApp As Object 'Outlook.Application
    Dim OutMail As Object 'Outlook.MailItem
    Dim OutAttachment As Object 'Outlook.Attachment
    Dim OutPropertyAcc As Object 'Outlook.PropertyAccessor
    Dim SendTo As String
    Dim CC As String
    Dim Subject As String
    Dim ExcelCells As Range
    Dim HTML As String
    Dim CellsImage As String, tempCellsFile As String
    
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001F"
    
    Set ExcelCells = ThisWorkbook.Worksheets("Sheet1").Range("A1:L35")   'range includes cells and charts
    SendTo = "email.address1@domain.com"
    CC = "email.address2@domain.com"
    Subject = "Your subject here"
    
    CellsImage = Replace(Timer, ".", "") & "image.jpg"
    tempCellsFile = Environ("temp") & "\" & CellsImage
    Save_Object_As_Picture ExcelCells, tempCellsFile
    
    'Construct email body as HTML string, with the range image in an img tag with corresponding src='cid:xxxx.jpg' attribute
    
    HTML = "<html>"
    HTML = HTML & "<p>The Excel range " & ExcelCells.Address(False, False) & " is embedded as an image in the email body:</p>"
    HTML = HTML & "<img src='cid:" & CellsImage & "'>"
    HTML = HTML & "</html>"
    
    Set OutApp = CreateObject("Outlook.Application") 'New Outlook.Application
    Set OutMail = OutApp.CreateItem(0) 'olMailItem
    
    'Create the email

    With OutMail
        .To = SendTo
        .CC = CC
        .Subject = Subject
        
        'Attach the file referenced in the img tag
        
        Set OutAttachment = .Attachments.Add(tempCellsFile)
        Set OutPropertyAcc = OutAttachment.PropertyAccessor
        OutPropertyAcc.SetProperty PR_ATTACH_CONTENT_ID, CellsImage
        
        .HTMLBody = HTML
        
        .Send   'or .Display
    End With
       
    'Delete the temporary image file
    
    Kill tempCellsFile
    
    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub


Private Sub Save_Object_As_Picture(saveObject As Object, imageFileName As String)

    'Save a picture of an object as a JPG/JPEG file
    
    'Arguments
    'saveObject     - any object in the CopyPicture method's 'Applies To' list, for example a Range or Shape
    'imageFileName  - the .jpg or .jpeg file name (including folder path if required) the picture will be saved as
    
    Dim temporaryChart As ChartObject
     
    Application.ScreenUpdating = False
    saveObject.CopyPicture xlScreen, xlPicture
    Set temporaryChart = ActiveSheet.ChartObjects.Add(0, 0, saveObject.Width, saveObject.Height)
    With temporaryChart
        .Activate
        .Border.LineStyle = xlLineStyleNone      'No border
        .Chart.Paste
        .Chart.Export imageFileName
        .Delete
    End With
    Application.ScreenUpdating = True
    Set temporaryChart = Nothing
    
End Sub