I wrote some script a automated tasks that will refresh certain Power Query and Pivot Table and copy the result as picture to a email. For some reason the last image of will always appear “messed up” with contents from several ranges overlapped with each other, why?

Ranged Image 4

Sub PasteRangeinMail()
Dim FilePath As String
Dim Outlook As Object
Dim OutlookMail As Object
Dim HTMLBody As String
Dim rng As Range
Dim dtToday As String
Dim lRow, lRow2 As Long



' Update
Sheets("Inbase_Activation").ListObjects("Inbase_Activation").QueryTable.Refresh False

Sheets("Inbase_Pending_Activation").ListObjects("Inbase_Pending_Activation").QueryTable.Refresh False

ThisWorkbook.RefreshAll

Application.Wait (Now + TimeValue("00:00:10"))

' Today
dtToday = Format(Date, "YYYYMMDD") - 2

' Rng
On Error Resume Next

Set rng = ThisWorkbook.Sheets("Activation NAC").Range("A1:J14")

If rng Is Nothing Then Exit Sub


Call createImage("Activation NAC", rng.Address, "RangeImage")

Application.CutCopyMode = False


' Rng2
On Error Resume Next

Set rng2 = ThisWorkbook.Sheets("Pending NAC").Range("A1:J14")

If rng2 Is Nothing Then Exit Sub


Call createImage("Pending NAC", rng2.Address, "RangeImage")

Application.CutCopyMode = False


' Rng3
ThisWorkbook.Sheets("Activation Bulk Case").Select

lRow = Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next

Set rng3 = ThisWorkbook.Sheets("Activation Bulk Case").Range("A1:C" & lRow)

If rng3 Is Nothing Then Exit Sub

Call createImage("Activation Bulk Case", rng3.Address, "RangeImage3")

Application.CutCopyMode = False

' Rng4
ThisWorkbook.Sheets("Pending Bulk Case").Select

lRow2 = Cells(Rows.Count, 1).End(xlUp).Row

On Error Resume Next

Set rng4 = ThisWorkbook.Sheets("Pending Bulk Case").Range("A1:C" & lRow2)

If rng4 Is Nothing Then Exit Sub

Call createImage("Pending Bulk Case", rng4.Address, "RangeImage4")

Application.CutCopyMode = False



' Off
With Application
.Calculation = xlManual
.ScreenUpdating = False
.EnableEvents = False
End With


' Mail
Set Outlook = CreateObject("outlook.application")
Set OutlookMail = Outlook.CreateItem(olMailItem)

FilePath = Environ$("temp") & ""
HTMLBody = "<span LANG=EN>" _
& "" _
& "Dear Jess," _
& "<br>" _
& "Please find MTD result of 5GBB activation as of " & dtToday & ":<br> " _
& "<br>" _
& "<img src='cid:RangeImage.jpg'>" _
& "<br>" _
& "<img src='cid:RangeImage2.jpg'>" _
& "<br>" _
& "<img src='cid:RangeImage3.jpg'>" _
& "<br>" _
& "<img src='cid:RangeImage4.jpg'>" _
& "<br>" _
& "<br>Regards</font></span>"

With OutlookMail
.Subject = "Inbase Summary as of " & dtToday
.HTMLBody = HTMLBody
.Attachments.Add FilePath & "RangeImage.jpg", olByValue
.Attachments.Add FilePath & "RangeImage2.jpg", olByValue
.Attachments.Add FilePath & "RangeImage3.jpg", olByValue
.Attachments.Add FilePath & "RangeImage4.jpg", olByValue
.To = " "
.CC = " "
.Display
End With

' On
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
.EnableEvents = True
End With


End Sub
Sub createImage(sheetName As String, rangeAddress As String, imageName As String)
    Dim ws As Worksheet
    Dim rng As Range
    Dim fileName As String

    Set ws = ThisWorkbook.Sheets(sheetName)
    Set rng = ws.Range(rangeAddress)

    fileName = Environ$("temp") & "" & imageName & ".jpg"

    rng.CopyPicture
    With ws.ChartObjects.Add(rng.Left, rng.Top, rng.Width, rng.Height)
        .Activate
        For Each Shape In ActiveSheet.Shapes
            Shape.Line.Visible = msoFalse
        Next
        .Chart.Paste
        .Chart.Export fileName, "JPG"
    End With

    ws.ChartObjects(ws.ChartObjects.Count).Delete
    Set rng = Nothing
End Sub

It’s there any way to avoid the “messed up” image?