Add a range as a image

Question

I want to add a range as image in my code. the range should be from A1 to d30, i would like to add it after this line:

Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine

This is my code:

Sub EnviarEmail()



Dim OutlookApp As Outlook.Application
Dim MItem As Outlook.MailItem
Dim cell As Range
Dim Asunto As String
Dim Correo As String
Dim Destinatario As String
Dim Saldo, A As String
Dim Msg As String


    
    If Range("f3") = 1 Then
    salso = "Buena tarde,"
     End If
     If Range("f3") = 2 Then
       salso = "Buena noche,"
     End If
     If Range("f3") = 3 Then
       salso = "Buen día,"
     End If


    Set OutlookApp = New Outlook.Application
    '


     For Each cell In Range("w1")
        '

        Asunto = "Constancia de entregas"

        Correo = cell.Value
        Saldo = salso
        FechaVencimiento = Now
        A = Range("d4")

        Msg = Saldo & vbNewLine & vbNewLine & vbNewLine & vbNewLine
        Msg = Msg & "Adjunto constancia de entregas del dia "
        Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine

        Msg = Msg & "Saludos," & vbNewLine & vbNewLine & vbNewLine & vbNewLine
        Msg = Msg & A & vbNewLine
        Msg = Msg & "Control de Calidad y Entregas" & vbNewLine & "Ext 210" & vbNewLine
        Msg = Msg & "Goodyear Rubber & Tire Co" & vbNewLine
        Msg = Msg & "www.goodyear.com" & vbNewLine
        
        '
        
        Set MItem = OutlookApp.CreateItem(olMailItem)
        With MItem
            .To = xxxx
            .CC = xxxx
            .Subject = Asunto
            .Body = Msg
            .Attachments.Add ActiveWorkbook.FullName
            .Send
            '
        End With
        '
    Next
    '
    
End Sub

Answer 1

You can use CopyPicture method to copy a range as an image.

And you can use WordEditor to edit a message as rich text.

' ...

 For Each cell In Range("w1")
    '

    Asunto = "Constancia de entregas"

    Correo = cell.Value
    Saldo = salso
    FechaVencimiento = Now
    A = Range("d4")
    '
    
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = "ktgk.chr66g@gmail.com"
        .CC = "ktgk.chr66g@gmail.com"
        .Subject = Asunto
        .Attachments.Add ActiveWorkbook.FullName
        .Display False
        With .GetInspector.WordEditor.Windows(1).Selection
            .Font.Name = "Calibri"
            .Font.Size = "11"
            Msg = ""
            Msg = Saldo & vbNewLine & vbNewLine & vbNewLine & vbNewLine
            Msg = Msg & "Adjunto constancia de entregas del dia "
            Msg = Msg & FechaVencimiento & " Todas las cantidades se encuentran correctamente ingresadas en el sistema." & vbNewLine & vbNewLine & vbNewLine & vbNewLine
            .TypeText Msg
            .TypeText Chr(13)

            ' Copy & paste a range as an image
            Range("A1:D30").CopyPicture
            .Paste

            .TypeText Chr(13)
            Msg = ""
            Msg = Msg & "Saludos," & vbNewLine & vbNewLine & vbNewLine & vbNewLine
            Msg = Msg & A & vbNewLine
            Msg = Msg & "Control de Calidad y Entregas" & vbNewLine & "Ext 210" & vbNewLine
            Msg = Msg & "Goodyear Rubber & Tire Co" & vbNewLine
            Msg = Msg & "www.goodyear.com" & vbNewLine
            .TypeText Msg
            
        End With
        .Send
        '
    End With
    '
Next
'
' Make sure messages are sent
OutlookApp.GetNamespace("MAPI").SendAndReceive True