VBA Copy-Paste Excel Range to Outlook as Picture – Picture Quality

The code below works perfectly fine however the picture quality is not particular good, certainly not as good if I do this task manually (copy range from excel and paste to outlook as picture).

Is there a way to improve the quality of the picture?

  • Prevent Excel from opening while creating excel file using interop
  • Excel VBA Copy and Paste Loop within Loop
  • Multiple ThisWorkbook in excel VBA in user defined function
  • Compare two column from two different sheets
  • Writing To A Range Using VBA array
  • How can I reference a workbook within another workbook to automatically open the file?
  • Sub Mail_Selection_Range_Outlook_Body()
    Dim TempFilePath As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim width As String
    Dim height As String
    Dim dayName As String
    On Error Resume Next
    Dim sh As Worksheet
    Set sh = Sheets("Overnights")
    'prepare subject line
    dayName = Format(Date, "dddd")
    subjectLine = "CEEMEA OVERNIGHTS: " & dayName & " " & testDate()
    'Create a new Microsoft Outlook session
    Set OutApp = CreateObject("outlook.application")
    'create a new message
    Set OutMail = OutApp.CreateItem(olMailItem)
    With OutMail
        .Subject = subjectLine
        .To = " "
        .CC = " "
        .BCC = " "
        'first we create the image as a JPG file
        Call createJpg("Overnights", "A1:V57", "DashboardFile")
        'we attached the embedded image with a Position at 0 (makes the attachment hidden)
        TempFilePath = Environ$("temp") & "\"
        .Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue, 0
        'Then we add an html <img src=''> link to this image
        'Note than you can customize width and height - not mandatory
        .HTMLBody = "<img src='cid:DashboardFile.jpg'" & "width=width height=heigth><br><br>" _
                    & .HTMLBody
    End With
    Set sh = Nothing
    End Sub
    Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    'converts a range to a jpec
    Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.width, Plage.height)
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    Set Plage = Nothing
    End Sub
    Function testDate()
    'Creats a subject line for the email
        Dim dt As Date
        Dim sfx As String
        dt = Date
        Select Case Right(Day(dt), 1)
        Case "1"
            sfx = """st"""
        Case "2"
            sfx = """nd"""
        Case "3"
            sfx = """rd"""
        Case Else
            sfx = """th"""
        End Select
        testDate = Format(dt, "d" & sfx & " mmmm yyyy")
    End Function

    MS Excel Spreadsheet is the best Office Software, Excel VBA and Excel Formulas make Spreadsheet work faster.