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?

  • How to end excel.exe process?
  • Excel count minimum required to reach total of consecutive cells
  • Array that outputs cells in a column AFTER a certain point
  • ArrayFormula More than 255 Characters .Replace Not Working
  • So, I have 6 “master” files to then divide into 40 separate files
  • Refining data set using R studio
  • 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
        .Display
        .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
    
        .Display
        '.Send
    End With
    
    Set sh = Nothing
    
    End Sub
    
    Sub createJpg(Namesheet As String, nameRange As String, nameFile As String)
    
    'converts a range to a jpec
    
    ThisWorkbook.Activate
    
    Worksheets(Namesheet).Activate
    
    Set Plage = ThisWorkbook.Worksheets(Namesheet).Range(nameRange)
    Plage.CopyPicture
    
    With ThisWorkbook.Worksheets(Namesheet).ChartObjects.Add(Plage.Left, Plage.Top, Plage.width, Plage.height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
    End With
    
    Worksheets(Namesheet).ChartObjects(Worksheets(Namesheet).ChartObjects.Count).Delete
    
    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.