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

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 :

CodePudding user response：

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

CodePudding user response：

Turning off gridlines in the worksheet did the trick. (Now I've no blur on sparklines)

[If Someone know how to copy sparklines from excel to outlook, please post it as answer. I will accept it since its the best way to do]