As part of my internship at a bank i've been tasked to automate a weekly hedging proposal. The idea is as follows: I gathered data, graphs and tables from different excel workbooks and brought them all together into one seperate worksheet. I've put the data, graphs and tables in chronological order. Now, I've managed to create a button using VBA's to export the data which automatically makes an outlook mail, i just need to get the graphs and the tables in there.
The first graph (Chart 15) comes after data range A14:A17. After the graph comes the first table, which is from range A36:I46. After data range A48:A50 comes the second table, which is from range A52:E57. We then get the second graph (Chart 2), which comes after data (text) A62:A65. Right after we've got our final table we need to export, which is in cells A89:K99. Unfortunately, I haven't been able to get the graphs and the tables in there. I've tried different methods on Google and even asked ChatGPT to write the code for me, but I can't seem to get the graphs and tables into the outlook mail.
**I initially used this code to export just the data without the graphs and tables as a first step, which worked just fine: **
Sub ExportToOutlook()
Dim olApp As Object
Dim olMail As Object
Dim bodyText As String
Dim cell As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(0) ' 0 = olMailItem
bodyText = ""
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("MyWorksheet")
' Add text from A1:A4
For Each cell In ws.Range("A1:A4")
If Trim(cell.Value) <> "" Then ' Only add non-empty cells
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the first range
' Add text from A6:A12
For Each cell In ws.Range("A6:A12")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the second range
' Add text from A14:A17
For Each cell In ws.Range("A14:A17")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the third range
' Add text from A36
If Trim(ws.Range("A36").Value) <> "" Then
bodyText = bodyText & ws.Range("A36").Value & vbCrLf
End If
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the fourth range
' Add text from A48:A50
For Each cell In ws.Range("A48:A50")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the fifth range
' Add text from A59:A60
For Each cell In ws.Range("A59:A60")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the sixth range
' Add text from A62:A65
For Each cell In ws.Range("A62:A65")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the seventh range
' Add text from A101:A105
For Each cell In ws.Range("A101:A105")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
With olMail
.Subject = "Exported Data from Excel"
.Body = Trim(bodyText) ' Use Trim to remove any trailing new line characters
.Display ' Use .Send to send without displaying
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
**After that I tried to get the graphs and tables in there, but it didn't work, so I asked ChatGPT. It changed things around, and gave me the following, and this is what im currently stuck with: **
rangesToInclude = Array("A1:A4", "A6:A12", "A14:A17", "A36", "A48:A50", "A59:A60", "A62:A65", "A101:A105")
For Each rng In rangesToInclude
For Each cell In ws.Range(rng)
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
bodyText = bodyText & vbCrLf ' Add space after each range
Next rng
' Set the email properties
With olMail
.Subject = "Exported Data from Excel"
.Body = Trim(bodyText) ' Use Trim to remove any trailing new line characters
' Display the email to paste the content
.Display
' Use the Word Editor of the email to paste images
On Error Resume Next
Set wdDoc = .GetInspector.WordEditor
' Check if wdDoc is valid
If Not wdDoc Is Nothing Then
' Copy Chart 15 as a picture
Set chartObj = ws.ChartObjects("Chart 15")
If Not chartObj Is Nothing Then
chartFileName = Environ$("TEMP") & "\Chart15.png"
chartObj.Chart.Export Filename:=chartFileName, FilterName:="PNG"
wdDoc.Application.Selection.InlineShapes.AddPicture chartFileName
wdDoc.Application.Selection.TypeParagraph ' Add a line break
End If
' Copy Table from A36:I46
ws.Range("A36:I46").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
' Copy Table from A52:E57
ws.Range("A52:E57").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
' Copy Chart 2 as a picture
Set chartObj = ws.ChartObjects("Chart 2")
If Not chartObj Is Nothing Then
chartFileName = Environ$("TEMP") & "\Chart2.png"
chartObj.Chart.Export Filename:=chartFileName, FilterName:="PNG"
wdDoc.Application.Selection.InlineShapes.AddPicture chartFileName
wdDoc.Application.Selection.TypeParagraph ' Add a line break
End If
' Copy Table from A89:K99
ws.Range("A89:K99").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
As part of my internship at a bank i've been tasked to automate a weekly hedging proposal. The idea is as follows: I gathered data, graphs and tables from different excel workbooks and brought them all together into one seperate worksheet. I've put the data, graphs and tables in chronological order. Now, I've managed to create a button using VBA's to export the data which automatically makes an outlook mail, i just need to get the graphs and the tables in there.
The first graph (Chart 15) comes after data range A14:A17. After the graph comes the first table, which is from range A36:I46. After data range A48:A50 comes the second table, which is from range A52:E57. We then get the second graph (Chart 2), which comes after data (text) A62:A65. Right after we've got our final table we need to export, which is in cells A89:K99. Unfortunately, I haven't been able to get the graphs and the tables in there. I've tried different methods on Google and even asked ChatGPT to write the code for me, but I can't seem to get the graphs and tables into the outlook mail.
**I initially used this code to export just the data without the graphs and tables as a first step, which worked just fine: **
Sub ExportToOutlook()
Dim olApp As Object
Dim olMail As Object
Dim bodyText As String
Dim cell As Range
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set olMail = olApp.CreateItem(0) ' 0 = olMailItem
bodyText = ""
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("MyWorksheet")
' Add text from A1:A4
For Each cell In ws.Range("A1:A4")
If Trim(cell.Value) <> "" Then ' Only add non-empty cells
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the first range
' Add text from A6:A12
For Each cell In ws.Range("A6:A12")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the second range
' Add text from A14:A17
For Each cell In ws.Range("A14:A17")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the third range
' Add text from A36
If Trim(ws.Range("A36").Value) <> "" Then
bodyText = bodyText & ws.Range("A36").Value & vbCrLf
End If
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the fourth range
' Add text from A48:A50
For Each cell In ws.Range("A48:A50")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the fifth range
' Add text from A59:A60
For Each cell In ws.Range("A59:A60")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the sixth range
' Add text from A62:A65
For Each cell In ws.Range("A62:A65")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
If bodyText <> "" Then bodyText = bodyText & vbCrLf ' Add space after the seventh range
' Add text from A101:A105
For Each cell In ws.Range("A101:A105")
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
With olMail
.Subject = "Exported Data from Excel"
.Body = Trim(bodyText) ' Use Trim to remove any trailing new line characters
.Display ' Use .Send to send without displaying
End With
Set olMail = Nothing
Set olApp = Nothing
End Sub
**After that I tried to get the graphs and tables in there, but it didn't work, so I asked ChatGPT. It changed things around, and gave me the following, and this is what im currently stuck with: **
rangesToInclude = Array("A1:A4", "A6:A12", "A14:A17", "A36", "A48:A50", "A59:A60", "A62:A65", "A101:A105")
For Each rng In rangesToInclude
For Each cell In ws.Range(rng)
If Trim(cell.Value) <> "" Then
bodyText = bodyText & cell.Value & vbCrLf
End If
Next cell
bodyText = bodyText & vbCrLf ' Add space after each range
Next rng
' Set the email properties
With olMail
.Subject = "Exported Data from Excel"
.Body = Trim(bodyText) ' Use Trim to remove any trailing new line characters
' Display the email to paste the content
.Display
' Use the Word Editor of the email to paste images
On Error Resume Next
Set wdDoc = .GetInspector.WordEditor
' Check if wdDoc is valid
If Not wdDoc Is Nothing Then
' Copy Chart 15 as a picture
Set chartObj = ws.ChartObjects("Chart 15")
If Not chartObj Is Nothing Then
chartFileName = Environ$("TEMP") & "\Chart15.png"
chartObj.Chart.Export Filename:=chartFileName, FilterName:="PNG"
wdDoc.Application.Selection.InlineShapes.AddPicture chartFileName
wdDoc.Application.Selection.TypeParagraph ' Add a line break
End If
' Copy Table from A36:I46
ws.Range("A36:I46").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
' Copy Table from A52:E57
ws.Range("A52:E57").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
' Copy Chart 2 as a picture
Set chartObj = ws.ChartObjects("Chart 2")
If Not chartObj Is Nothing Then
chartFileName = Environ$("TEMP") & "\Chart2.png"
chartObj.Chart.Export Filename:=chartFileName, FilterName:="PNG"
wdDoc.Application.Selection.InlineShapes.AddPicture chartFileName
wdDoc.Application.Selection.TypeParagraph ' Add a line break
End If
' Copy Table from A89:K99
ws.Range("A89:K99").Copy
wdDoc.Application.Selection.Paste
wdDoc.Application.Selection.TypeParagraph ' Add a line break
1 Answer
Reset to default 0Okay, first things first: stop using MailItem.Body (which only support Plain Text), and start using MailItem.HTMLBody (which allows you to edit the HTML directly)
With olMail
.Subject = "Exported Data from Excel"
.HTMLBody = Trim(bodyText) ' Use Trim to remove any trailing new line characters
.Display ' Use .Send to send without displaying
End With
Of course, part of that means that certain characters (such as New Lines, Greater-Than or Less-Than symbols, or Ampersands) will not display correctly unless you change them to their HTML code equivalents. So, let's create a quick and basic function for that, which you can expand as needed:
Function TextToHTML(Value As String) As String
Dim strTEMP As String
strTEMP = Trim(Value)
'Replace Symbols with HTML Codes
strTEMP = Replace(strTEMP, "&", "&")
strTEMP = Replace(strTEMP, ">", ">")
strTEMP = Replace(strTEMP, "<", "<")
'Fix New-Lines
strTEMP = Replace(strTEMP, vbCrLf, vbLf)
strTEMP = Replace(strTEMP, vbCr, vbLf)
strTEMP = Replace(strTEMP, vbLf, "<br/>")
TextToHTML = strTEMP
End Function
Next, you'll want to convert your Tables into HTML Tables, with the <table>, <tr>, <td> and <th> tags. Again, we can build a function that will loop through the cells in the range and output the HTML as a string:
Function RangeToHTMLTable(Target As Range, Optional HeaderRow As Boolean = False) As String
If Target.Areas.Count > 1 Then Exit Function
Dim strTable As String, strRow As String, lRow As Long, lColumn As Long, strType As String
Dim rCell As Range, rMerge As Range, strText As String
'Using a proper Style Header and/or Classes would be more effective
Const strStyle As String = " style=""border:1px solid black; border-collapse:collapse;"""
'Start of the Table
strTable = "<table" & strStyle & ">"
'Loop through each row of the table
For lRow = 1 To Target.Rows.Count
'Start a New Row
strRow = "<tr>"
If HeaderRow And lRow = 1 Then
strType = "th" 'Header
Else
strType = "td" 'Data
End If
'Loop through each Cell in the Row
For lColumn = 1 To Target.Columns.Count
Set rCell = Target.Cells(lRow, lColumn)
Set rMerge = rCell.MergeArea
'Change text to HTML formatting
'Currently just does the raw text directly, and ignores Cell formatting such as Bold/Italic/Colours/etc
strText = TextToHTML(rCell.Text)
'Add the Cell to the Row when necessary
If rCell.MergeCells Then
'If Merged, only process the top-left cell
If Not Intersect(rCell.Cells(1, 1), rMerge.Cells(1, 1)) Is Nothing Then
strRow = strRow & "<" & strType
If rMerge.Rows.Count > 1 Then strRow = strRow & " rowspan=""" & rMerge.Rows.Count & """"
If rMerge.Columns.Count > 1 Then strRow = strRow & " colspan=""" & rMerge.Columns.Count & """"
strRow = strRow & strStyle & ">" & strText & "</" & strType & ">"
End If
Else
'Not Merged
strRow = strRow & "<" & strType & strStyle & ">" & strText & "</" & strType & ">"
End If
Next lColumn
'End of the Row
strRow = strRow & "</tr>"
'Add the Row to the Table
strTable = strTable & strRow
Next lRow
'End of the Table
strTable = strTable & "</table>"
'Return the completed table
RangeToHTMLTable = strTable
End Function
This means you can quickly add a Table to an Email with something like
bodyText = bodyText & RangeToHTMLTable(ws.Range("A52:E57")) & "<br/><br/>"
or
With ws.Range("A52:E57")
If Application.CountA(.Resize()) > 0 Then
'Table is not Empty
bodyText = bodyText & RangeToHTMLTable(.Resize()) & "<br/><br/>"
End If
End With
For Charts, there are a couple of ways to go about it. The method I will use here is to convert the Chart to an Image, and then add the Image to the Email.
The advantage here is, of course, that you can easily adapt the code to include other images, by just excluding the first step.
So, to export the Image, I threw together a quick Function that will put it in your TEMP folder, and return the FileName:
Function ExportChartAsImage(Target As ChartObject) As String
ExportChartAsImage = "" 'Default to blank
Dim lAttempt As Long, sFolder As String, sName As String, ForbiddenChars As Variant, element As Variant
ForbiddenChars = Split("* "" / \ < > : | ?", " ")
sFolder = Environ("TEMP") & "\" '{USER}\AppData\Local\Temp\
sName = Target.Name
'Remove any characters that are Forbidden in Filenames
For Each element In ForbiddenChars
sName = Replace(sName, CStr(element), "_")
Next element
'Find a Filename that is not already in use...
For lAttempt = 0 To 99 'Only try 100 times
If Len(Dir(sFolder & sName & IIf(lAttempt = 0, "", " (" & lAttempt & ")") & ".png")) < 3 Then
sName = sName & IIf(lAttempt = 0, "", " (" & lAttempt & ")") & ".png"
Exit For
End If
Next lAttempt
'If unable to find a free Filename, return the default value and exit
If Right(sName, 4) <> ".png" Then Exit Function
'Export the Image to your TEMP folder, with the Filename
Target.Chart.Export sFolder & sName
DoEvents
'If the file was successfully exported, then return the Filepath
If Len(Dir(sFolder & sName)) > 3 Then ExportChartAsImage = sFolder & sName
End Function
To hold the returned FileName, I would recommend adding a new Variable, such as Dim strChartFile AS String to hold it while you check if the export worked and attach it, then display it as an HTML image:
'Try to export the Chart
strChartFile = ExportChartAsImage(ws.ChartObjects("Chart 15"))
If strChartFile <> "" Then 'If the chart was successfully exported
olMail.Attachments.Add strChartFile, 1, 0 'Add as a Hidden attachment
DoEvents
Kill strChartFile 'Delete the temporary image, since it is no longer required
DoEvents
'Get just the FileName, without the folder
strChartFile = Mid(strChartFile, InStrRev(strChartFile, "\") + 1)
'Add the Image to the HTML Body, using the FileName
bodyText = bodyText & "<img src=""cid:" & strChartFile & """><br/><br/>"
End If
(If you are adapting this to add other images, you'll probably want to get rid of the line that deletes the temporary chart image)
Chart.Exportmethod, then you will need to add the file as an attachment (optionally, making it invisible) and then reference that to make it display. If you are using Copy/Paste instead, then you might want to look at theChart.CopyPicturemethod. Finally: you can create a "manual" version of the email, and use VBA to look at theMailItem.HTMLBody– Chronocidal Commented Mar 24 at 23:11