How to copy Range with Excel SparkLines and paste it into Outlook - excel

Question

Currently I am using this code which does not take in count the sparklines :
Sub generatemail()
Dim r As Range
Set r = Range("A1:F71")
r.Copy
Dim outlookApp As Outlook.Application
Set outlookApp = CreateObject("Outlook.Application")
Dim outMail As Outlook.MailItem
Set outMail = outlookApp.CreateItem(olMailItem)
outMail.Display
Dim wordDoc As Word.Document
Set wordDoc = outMail.GetInspector.WordEditor
wordDoc.Range.Paste
End Sub
The workaround I found to take in count spark line is to paste the image of the range with
wordDoc.Range.PasteAndFormat wdChartPicture
But they are blurred :
Does a way exist to copy sparkline ? (with Range.Copy) If it is not possible how would I get a better screen shot without blur ?
Note : When I do this by and the SparkLine are not blur :

Answer 1

I usually create a picture file then insert it on the mail. This works fine for me, try it.
Option Explicit
Private PicFilename As String
Sub generatemail()
Dim r As Range: Set r = Range("A1:F71")
' Create picture
Call createPicture("xChart", r)
Dim outlookApp As Outlook.Application: Set outlookApp = CreateObject("Outlook.Application")
Dim OutMail As Outlook.MailItem: Set OutMail = outlookApp.CreateItem(olMailItem)
' Display mail
OutMail.Display
' Insert picture
Dim shp As Word.InlineShape
Dim wordDoc As Word.Document: Set wordDoc = OutMail.GetInspector.WordEditor
Set shp = wordDoc.Range.InlineShapes.AddPicture(PicFilename)
End Sub
Public Function createPicture(picName As String, picRng As Range) As Boolean
Dim PicTop, PicLeft, PicWidth, PicHeight As Long
Dim oChart As ChartObject
createPicture = False
PicFilename = ThisWorkbook.Path & "\" & picName & ".jpg"
On Error Resume Next
Kill PicFilename
ActiveSheet.ChartObjects(1).Delete
On Error GoTo 0
On Error GoTo ErrHandler
' Delete any existing picture
On Error Resume Next
If Dir(PicFilename) > 0 Then Kill (PicFilename)
On Error GoTo 0
' Create a bitmap image
On Error Resume Next
picRng.CopyPicture xlScreen, xlBitmap
On Error GoTo 0
' Create a new Temporary Chart
PicTop = picRng.Top
PicLeft = picRng.Left
PicWidth = picRng.Width
PicHeight = picRng.Height
Set oChart = ActiveSheet.ChartObjects.Add(Left:=PicLeft, Top:=PicTop, Width:=PicWidth, Height:=PicHeight)
With oChart
.Name = picName
.Activate
' Select chart area
.Chart.Parent.Select
' Paste the Picture in the chart area
.Chart.Paste
' Save chart as picture
.Chart.Export PicFilename
' Delete Picture
.Delete
createPicture = True
End With
exitRoutine:
Exit Function
ErrHandler:
Debug.Print Now() & ": " & Err.Description
Resume exitRoutine
End Function