Mail range as picture in the body of Outlook mail

Important message to visitors of this page

Ron de Bruin decided to remove all Windows Excel content from his website for personal reasons. If you want to know why, head over to rondebruin.nl.

Luckily, Ron was kind enough to allow me to publish all of his Excel content here.

Most of these pages are slightly outdated and may contain links that don 't work. Please inform me if you find such an error and I'll try to fix it.

Kind regards

Jan Karel Pieterse

Important read this :

The code on this page is only working when you use Outlook as your mail program.
Copy the code in a Standard module of your workbook, if you just started with VBA see this page.
Where do I paste the code that I find on the internet

Check out this Tip page for more Outlook mail examples

For example this page for another body example : Mail one worksheet in the body of the mail

Example

Copy the macro and the function below in your workbook if you want to test it. The code will display the mail so you can check it out first, you can change it later to send the mail directly if you want. Change the mail adress before you hit the send button. You can change the size of the picture also in the code so it looks good. Note : Read the comments in the code.

Note: I get a few mails from users that have problems that the reciever not see the jpg in the mail, if you have that problem change the 0 to 1 in this code line and try again : .Attachments.Add MakeJPG, 1, 0

Sub Mail_small_Text_And_JPG_Range_Outlook()
    'Ron de Bruin, 12-03-2022
    'This macro use the function named : CopyRangeToJPG
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Dim MakeJPG As String

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    strbody = "Dear Customer" & "<br><br>" & _
        "Below you find a picture of your data." & "<br>" & _
        "If you need more information let me know." & "<br><br>" & _
        "Regards Ron<br>"
              
    'Create JPG file of the range
    'Only enter the Sheet name and the range address
    MakeJPG = CopyRangeToJPG("Sheet1", "A1:H50")

    If MakeJPG = "" Then
        MsgBox "Something go wrong, we can't create the mail"
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
        Exit Sub
    End If

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .Attachments.Add MakeJPG, 1, 0
        'Note: Change the width and height as needed
        .HTMLBody = "<html><p>" & strbody & "</p><img src=""cid:NamePicture.jpg"" width=750 height=700></html>"
        .Display 'or use .Send
    End With
    On Error GoTo 0

    Kill MakeJPG

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub



Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
    'Ron de Bruin, 25-10-2019
    Dim PictureRange As Range

    With ActiveWorkbook
        On Error Resume Next
        .Worksheets(NameWorksheet).Activate
        Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
        
        If PictureRange Is Nothing Then
            MsgBox "Sorry this is not a correct range"
            On Error GoTo 0
            Exit Function
        End If
        
        PictureRange.CopyPicture
        With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
            .Activate
            .Chart.Paste
            .Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
        End With
        .Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
    End With
    
    CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
    Set PictureRange = Nothing
End Function

Ron de BruinExcel Automation