How to copy range of cells as bitmaps in email body?

Question

I have 7 different cell ranges I need to copy and paste as bitmap images in my e-mail body.

The ranges are E3, V29; e30, v54; e55, v80; e81 , v145; x3, af8; x9, af37; e3, v180

Sub Criaremail()

    Dim Outlook As Object
    Dim email As Object
    Dim xInspect As Object
    Dim pageEditor As Object

    assunto = Sheets("Corpo do Email").Range("AH1")
    para = Sheets("Corpo do Email").Range("AH2")

    Set Outlook = CreateObject("Outlook.application")
    Set email = Outlook.CreateItem(0)

    With email
        .Display
        .Subject = assunto
        .To = para
        .Body = ""

    Set xInspect = email.GetInspector
    Set pageEditor = xInspect.WordEditor

    Sheets("Corpo do Email").Range("E3:V29").Copy

    pageEditor.Application.Selection.Start = Len(.Body)
    pageEditor.Application.Selection.End = 
    pageEditor.Application.Selection.Start
    pageEditor.Application.Selection.PasteSpecial (wdPasteBitmap)
    .Display

    Set pageEditor = Nothing
    Set xInspect = Nothing

    End With

    Set email = Nothing
    Set Outlook = Nothing

End Sub

https://stackoverflow.com/questions/29092999/pasting-an-excel-range-into-an-email-as-a-picture — Michal Rosa, May 30 '19 at 01:39
Possible duplicate of [Pasting an Excel range into an email as a picture](https://stackoverflow.com/questions/29092999/pasting-an-excel-range-into-an-email-as-a-picture) — Michal Rosa, May 30 '19 at 01:40

Asger · Accepted Answer · 2019-05-31T16:21:00.837

You can either copy each of your 7 ranges individually or you loop over each area of a multirange.
I added two alternatives for pasting: Paste as chart or as bitmap.
With my code, you'll also retain your default email signature.

Sub Criaremail()

    Dim Outlook As Object
    Dim email As Object
    Dim xInspect As Object
    Dim pageEditor As Object
    Dim assunto As String, para As String
    Dim myRange As Excel.Range

    assunto = Sheets("Corpo do Email").Range("AH1")
    para = Sheets("Corpo do Email").Range("AH2")

    Set Outlook = CreateObject("Outlook.application")
    Set email = Outlook.CreateItem(0)

    With email
        .Subject = assunto
        .To = para

        Set xInspect = email.GetInspector
        Set pageEditor = xInspect.WordEditor

        pageEditor.Range.Characters(1).Select
        With pageEditor.Application.Selection
            .Collapse 1                 ' 1 = wdCollapseStart
            .InsertAfter "Hi," & vbCrLf & vbCrLf & _
                     "here's the info:" & vbCrLf
            .Collapse 0                 ' 0 = wdCollapseEnd
            For Each myRange In Sheets("Corpo do Email") _
                .Range( _
                "E3:V29, E30:V54, E55:V80, E81:V145, X3:AF8, X9:AF37, E3:V180" _
                ).Areas
                myRange.Copy
                '.PasteAndFormat Type:=13       ' 13 = wdChartPicture
                .PasteSpecial DataType:=4       ' 4 = wdPasteBitmap
                .InsertParagraphAfter
                .Collapse 0
            Next myRange
            .InsertAfter "Best wishes,"
            .Collapse 0
        End With
        .Display

        Set pageEditor = Nothing
        Set xInspect = Nothing

    End With

    Set email = Nothing
    Set Outlook = Nothing

End Sub

How can I change this code to paste the picture as Bitmap and do it for 7 more different ranges in the same e-mail body? — DanC, May 30 '19 at 18:33

How to copy range of cells as bitmaps in email body?

1 Answers1