I have a process in which I use my laptops task scheduler to wake up and open an Excel file. Upon opening the file, a macro runs that processes a few power queries, records some data, updates a chart, and then sends an email report with the chart in the body of the email. The process works as intended with the exception of updating the chart. Can Excel update a chart through VBA and attach it to an email as I am trying to do?
Sub Refresh_Sent_and_Received()
Dim myChart As ChartObject
Dim myCharts As ChartObjects
Dim myChartname As String
Set myCharts = ActiveSheet.ChartObjects
'Update the reamianing queries at the end of the day.
Application.Calculation = xlManual
Workbooks("Email Tracker").Connections("Query - Sent").Refresh
Application.CalculateUntilAsyncQueriesDone
Workbooks("Email Tracker").Connections("Query - Received").Refresh
Application.CalculateUntilAsyncQueriesDone
Workbooks("Email Tracker").Connections("Query - Inbox (EOD)").Refresh
Application.CalculateUntilAsyncQueriesDone
Application.Calculation = xlAutomatic
'Log the query data in the tracker sheet.
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B11").Value = Format(Now, "m/d")
Rows("12:12").Select
Selection.EntireRow.Hidden = True
Range("C6:AQ6").Select
Selection.Copy
NextFree = Range("C10:C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("C" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Font.Bold = False
Selection.Font.Underline = xlUnderlineStyleNone
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Application.CutCopyMode = False
Range("B8").Select
'Time stamp
Range("C2").Value = Format(Now, "hh: mm AM/PM mmm/d")
'Update the graph data
ThisWorkbook.Worksheets("Graph").Activate
Application.CalculateFull
For Each myChart In myCharts
myChartname = myChart.Name
ActiveSheet.ChartObjects(myChartname).Chart.Refresh
Next
Range("D17").Select
ThisWorkbook.Save
'Send the graph via Outlook
Send_Email.sendMail
'Save and close
ThisWorkbook.Save
If Workbooks.Count = 1 Then
Application.Quit
End If
ThisWorkbook.Close (False)
End Sub
Sub sendMail()
Dim FilePath As String
Dim Outlook As Object
Dim OutlookMail As Object
Dim HTMLBody As String
Dim rng As Range
On Error Resume Next
Set rng = ThisWorkbook.Worksheets("Graph").Range("B4:S39")
If rng Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Outlook = CreateObject("outlook.application")
Set OutlookMail = Outlook.CreateItem(olMailItem)
Call createImage(ActiveSheet.Name, rng.Address, "RangeImage")
FilePath = Environ$("temp") & "\"
HTMLBody = "<span LANG=EN>" _
& "<p class=style1><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello Joe," _
& "<br><br>" _
& "Please refer to the gragh below for today's Distributor Support database update.<br> " _
& "<br>" _
& "<img src='cid:RangeImage.jpg'>" _
& "<br>" _
& "<br>Have a great day," _
& "<br><br>" _
& "Distributor Support RPA</font></span>"
With OutlookMail
.Subject = Worksheets("Graph").Range("V7")
.HTMLBody = HTMLBody & "<br><br>" & .HTMLBody
.Attachments.Add FilePath & "RangeImage.jpg", olByValue
.To = Worksheets("Graph").Range("V4")
.CC = Worksheets("Graph").Range("V5")
.Send
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub createImage(SheetName As String, rngAddrss As String, nameFile As String)
Dim rngJpg As Range
Dim Shape As Shape
Set rngJpg = ThisWorkbook.Worksheets("Graph").Range("B4:S39")
rngJpg.CopyPicture
With ThisWorkbook.Worksheets("Graph").ChartObjects.Add(rngJpg.Left, rngJpg.Top, rngJpg.Width, rngJpg.Height)
.Activate
For Each Shape In ActiveSheet.Shapes
Shape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets("Graph").ChartObjects(Worksheets("Graph").ChartObjects.Count).Delete
Set rngJpg = Nothing
End Sub
Sub Refresh_Sent_and_Received()
Dim myChart As ChartObject
Dim myCharts As ChartObjects
Dim myChartname As String
Set myCharts = ActiveSheet.ChartObjects
'Update the reamianing queries at the end of the day.
Application.Calculation = xlManual
Workbooks("Email Tracker").Connections("Query - Sent").Refresh
Application.CalculateUntilAsyncQueriesDone
Workbooks("Email Tracker").Connections("Query - Received").Refresh
Application.CalculateUntilAsyncQueriesDone
Workbooks("Email Tracker").Connections("Query - Inbox (EOD)").Refresh
Application.CalculateUntilAsyncQueriesDone
Application.Calculation = xlAutomatic
'Log the query data in the tracker sheet.
Rows("11:11").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B11").Value = Format(Now, "m/d")
Rows("12:12").Select
Selection.EntireRow.Hidden = True
Range("C6:AQ6").Select
Selection.Copy
NextFree = Range("C10:C" & Rows.Count).Cells.SpecialCells(xlCellTypeBlanks).Row
Range("C" & NextFree).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.Font.Bold = False
Selection.Font.Underline = xlUnderlineStyleNone
With Selection.Font
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Application.CutCopyMode = False
Range("B8").Select
'Time stamp
Range("C2").Value = Format(Now, "hh: mm AM/PM mmm/d")
'Update the graph data
ThisWorkbook.Worksheets("Graph").Activate
Application.CalculateFull
For Each myChart In myCharts
myChartname = myChart.Name
ActiveSheet.ChartObjects(myChartname).Chart.Refresh
Next
Range("D17").Select
ThisWorkbook.Save
'Send the graph via Outlook
Send_Email.sendMail
'Save and close
ThisWorkbook.Save
If Workbooks.Count = 1 Then
Application.Quit
End If
ThisWorkbook.Close (False)
End Sub
Sub sendMail()
Dim FilePath As String
Dim Outlook As Object
Dim OutlookMail As Object
Dim HTMLBody As String
Dim rng As Range
On Error Resume Next
Set rng = ThisWorkbook.Worksheets("Graph").Range("B4:S39")
If rng Is Nothing Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set Outlook = CreateObject("outlook.application")
Set OutlookMail = Outlook.CreateItem(olMailItem)
Call createImage(ActiveSheet.Name, rng.Address, "RangeImage")
FilePath = Environ$("temp") & "\"
HTMLBody = "<span LANG=EN>" _
& "<p class=style1><span LANG=EN><font FACE=Calibri SIZE=3>" _
& "Hello Joe," _
& "<br><br>" _
& "Please refer to the gragh below for today's Distributor Support database update.<br> " _
& "<br>" _
& "<img src='cid:RangeImage.jpg'>" _
& "<br>" _
& "<br>Have a great day," _
& "<br><br>" _
& "Distributor Support RPA</font></span>"
With OutlookMail
.Subject = Worksheets("Graph").Range("V7")
.HTMLBody = HTMLBody & "<br><br>" & .HTMLBody
.Attachments.Add FilePath & "RangeImage.jpg", olByValue
.To = Worksheets("Graph").Range("V4")
.CC = Worksheets("Graph").Range("V5")
.Send
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Sub createImage(SheetName As String, rngAddrss As String, nameFile As String)
Dim rngJpg As Range
Dim Shape As Shape
Set rngJpg = ThisWorkbook.Worksheets("Graph").Range("B4:S39")
rngJpg.CopyPicture
With ThisWorkbook.Worksheets("Graph").ChartObjects.Add(rngJpg.Left, rngJpg.Top, rngJpg.Width, rngJpg.Height)
.Activate
For Each Shape In ActiveSheet.Shapes
Shape.Line.Visible = msoFalse
Next
.Chart.Paste
.Chart.Export Environ$("temp") & "\" & nameFile & ".jpg", "JPG"
End With
Worksheets("Graph").ChartObjects(Worksheets("Graph").ChartObjects.Count).Delete
Set rngJpg = Nothing
End Sub
Last edited: