How do I insert multiple images of different ranges in an outlook message

[Philippe.T]

I managed to create an outlook mail with an image of a given range. However, trying to insert 2 images of different ranges results in one of the images being displayed correctly while the other results in "The picture can't be displayed"
This is what I have so far.

Sub test()


Dim OApp As Object
Dim OMail As Object
Dim signature As String
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
'------------------------------------------------------------------
'MAIL BODY
'------------------------------------------------------------------
Dim mailBody As String
mailBody = ""
'------------------------------------------------------------------
'CREATE MAIL IN OUTLOOK
'------------------------------------------------------------------
With OMail
    .To = "TEST@GMAIL.COM"
    .CC = ""
    .BCC = ""
    .Subject = "SUBJECT"
    .Display
    signature = .HTMLBody
    '------------------------------------------------------------------
    'IMAGE OF SELECTION  1ST
    '------------------------------------------------------------------
    Dim wdDoc As Word.Document
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set olApp = CreateObject("Outlook.Application")
    Set wdDoc = OMail.GetInspector.WordEditor
    wdDoc.Range.PasteAndFormat Type:=wdChartPicture
    With wdDoc
        .InlineShapes(1).Height = 170
    End With




    First = .HTMLBody
    '------------------------------------------------------------------
    'IMAGE OF SELECTION 2ND
    '------------------------------------------------------------------
    Sheets("X").Range("B2:CW132").CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set olApp = CreateObject("Outlook.Application")
    Set wdDoc = OMail.GetInspector.WordEditor
    wdDoc.Range.PasteAndFormat Type:=wdChartPicture
    With wdDoc
        .InlineShapes(1).Height = 370
    End With
    '------------------------------------------------------------------
    .HTMLBody = mailBody & vbNewLine & First & .HTMLBody & signature




End With
End Sub

 

[Philippe.T]

Not possible?

 

[Logit]

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim rng2 As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
Set rng2 = Nothing


' Only send the visible cells in the selection.
Set rng = Sheets("Sheet1").Range("A1:M10")
Set rng2 = Sheets("Sheet1").Range("A11:M20")


If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Your Subject Here"


    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                RangetoHTML(rng2) & "<br><br>" & _
                "Text below Excel cells.</p>"
    
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    '.Send
    .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)
    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 past 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