Not able to loop for converting range into image

[ganeshpoojary05]

Dear All,


Please help me with a vba code to convert a particular range to an image through looping. I'm using the below code, however I'm not able to convert range into image through looping. I'm using excel and outlook 2016.


Sub sendMailj()
Dim TempFilePath As String
Dim xOutApp As Object
Dim xOutMail As Object
Dim xHTMLBody As String
Dim xRg As Range
Dim i As Integer



For i = 2 To 5
On Error Resume Next
Set xRg = Sheets("Template").Range("D44:O71")
If xRg Is Nothing Then Exit Sub
With Application
'.Calculation = xlAutomatic
.ScreenUpdating = False
.EnableEvents = False
End With
Set xOutApp = CreateObject("outlook.application")
Set xOutMail = xOutApp.CreateItem(olMailItem)
Call createJpg(ActiveSheet.Name, xRg.Address, "DashboardFile")
TempFilePath = Environ$("temp") & ""
xHTMLBody = "<span LANG=EN>" _
& "<p class=style2><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "<br>" _
& "<img src='cid:DashboardFile.jpg'>" _
& "</font></span>"
With xOutMail
.Subject = "Welcome"
.HTMLBody = xHTMLBody
.Attachments.Add TempFilePath & "DashboardFile.jpg", olByValue
.To = Cells(i, 2)
.CC = " "
.Display
End With

Next i

End Sub








Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
Dim xRgPic As Range
ThisWorkbook.Activate
Worksheets(SheetName).Activate
Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
xRgPic.CopyPicture
With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & "" & nameFile & ".jpg", "JPG"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub