none
How to put charts and tables in a single email using Excel Macro? RRS feed

  • Question

  •  I want to put the charts and tables in a single email when it runs, it end up having charts in one email and tables in another email.

    Here are my codes:

    Public Sub Insert_Charts_In_New_Email()

    Dim outApp As Object 'Outlook.Application
    Dim outMail As Object 'Outlook.MailItem
    Dim wEditor As Object 'Word.Document
    Dim wRange As Object 'Word.Range
    Dim chartsSheet As Object
    Dim chartObj As ChartObject
    Dim chartWidthCm As Single, chartHeightCm As Single

    'Required chart dimensions in the email

    chartWidthCm = 25.93
    chartHeightCm = 16.95

    'Sheet1 contains the charts

    Set chartsSheet = ThisWorkbook.Sheets("Defects")
    Set chartsSheet2 = ThisWorkbook.Sheets("Test Execution (Manual)")
    Set chartsSheet3 = ThisWorkbook.Sheets("Ageing JIRAs")
    Set chartsSheet4 = ThisWorkbook.Sheets("JIRA_List")
    Set chartsSheet5 = ThisWorkbook.Sheets("Summary-Guidelines")

    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(olMailItem)

    outMail.Display

    Set wEditor = outApp.ActiveInspector.WordEditor
    Set wRange = wEditor.Application.ActiveDocument.Content

    'Ensure subsequent inserts and pastes appear above automatic email signature

    wRange.Collapse 1 'Direction:=wdCollapseStart

    wRange.InsertAfter "Text at top" & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    Set chartObj = chartsSheet2.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    'Temporarily resize Chart 1 and insert in email
    Set chartObj = chartsSheet.ChartObjects("Chart 2")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    Set chartObj = chartsSheet.ChartObjects("Chart 3")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    'Temporarily resize Chart 2 and insert in email

    Set chartObj = chartsSheet.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    'Temporarily resize Chart 3 and insert in email

    'Temporarily resize Chart 4 and insert in email

    Set chartObj = chartsSheet3.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart1 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    'Copy range of interest
    Dim r As Range
    Dim r2 As Range
    Dim r3 As Range
    Dim r4 As Range

    Set r = chartsSheet5.Range("B3:F23")
    Set r2 = chartsSheet2.Range("A57:L63")
    Set r3 = chartsSheet.Range("A60:F63")
    Set r4 = chartsSheet4.Range("A10:Q174")

    'Open a new mail item

    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(olMailItem)


    'Get its Word editor
    outMail.Display

    Set wEditor = outApp.ActiveInspector.WordEditor

    Dim thisRange As Range

    r.Copy
    wEditor.Range.PasteAndFormat wdChartPicture
    r2.Copy
    wEditor.Range(1, wEditor.Characters.Count).PasteAndFormat wdChartPicture
    r3.Copy
    wEditor.Range(2, wEditor.Characters.Count).PasteAndFormat wdChartPicture
    r4.Copy
    wEditor.Range(3, wEditor.Characters.Count).PasteAndFormat wdChartPicture

    End Sub

    Private Sub Insert_Resized_Chart(thisChartObject As ChartObject, newWidthCm As Single, newHeightCm As Single, wordRange As Object)

    'Arguments
    'thisChartObject - the ChartObject to be resized
    'newWidthCm - new width in centimeters
    'newHeighCm - new height in centimeters
    'wordRange - the current position in the email, as a Word.Range object

    Dim chartShape As Shape
    Dim currentWidth As Single
    Dim currentHeight As Single

    'Get the chart as a Shape

    Set chartShape = thisChartObject.Parent.Shapes(thisChartObject.Name)

    'Change chart to new dimensions

    With chartShape
    currentWidth = .Width
    currentHeight = .Height
    .Width = Application.CentimetersToPoints(newWidthCm)
    .Height = Application.CentimetersToPoints(newHeightCm)
    Debug.Print "Before: "; currentWidth; currentHeight, "After: "; .Width; .Height
    End With

    'Insert chart into email

    thisChartObject.Chart.ChartArea.Copy
    wordRange.PasteSpecial , , , , 4 'DataType:=wdPasteBitmap

    'Restore original dimensions

    With chartShape
    .Width = currentWidth
    .Height = currentHeight
    End With

    End Sub


    Wednesday, June 7, 2017 1:45 AM

All replies

  • I wasn't able to resize the tables as well as put the charts and tables in a single email when it runs, it end up having charts in one email and tables in another email. How do I add the texts as well?

    Here are my codes:

    Public Sub Insert_Charts_In_New_Email()

    Dim outApp As Object 'Outlook.Application
    Dim outMail As Object 'Outlook.MailItem
    Dim wEditor As Object 'Word.Document
    Dim wRange As Object 'Word.Range
    Dim chartsSheet As Object
    Dim chartObj As ChartObject
    Dim chartWidthCm As Single, chartHeightCm As Single




    'Required chart dimensions in the email

    chartWidthCm = 25.93
    chartHeightCm = 16.95

    'Sheet1 contains the charts

    Set chartsSheet = ThisWorkbook.Sheets("Defects")
    Set chartsSheet2 = ThisWorkbook.Sheets("Test Execution (Manual)")
    Set chartsSheet3 = ThisWorkbook.Sheets("Ageing JIRAs")
    Set chartsSheet4 = ThisWorkbook.Sheets("JIRA_List")
    Set chartsSheet5 = ThisWorkbook.Sheets("Summary-Guidelines")

    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(olMailItem)

    outMail.Display

    Set wEditor = outApp.ActiveInspector.WordEditor
    Set wRange = wEditor.Application.ActiveDocument.Content

    'Ensure subsequent inserts and pastes appear above automatic email signature

    wRange.Collapse 1 'Direction:=wdCollapseStart

    wRange.InsertAfter "Text at top" & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd


    Set chartObj = chartsSheet2.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd




    'Temporarily resize Chart 1 and insert in email
    Set chartObj = chartsSheet.ChartObjects("Chart 2")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd




    Set chartObj = chartsSheet.ChartObjects("Chart 3")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd




    'Temporarily resize Chart 2 and insert in email

    Set chartObj = chartsSheet.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd

    'Temporarily resize Chart 3 and insert in email




    'Temporarily resize Chart 4 and insert in email

    Set chartObj = chartsSheet3.ChartObjects("Chart 1")
    Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    wRange.InsertParagraphAfter
    wRange.InsertAfter "Text below Chart1 " & Time & vbNewLine
    wRange.Collapse 0 'Direction:=wdCollapseEnd



    'Copy range of interest
    Dim r As Range
    Dim r2 As Range
    Dim r3 As Range
    Dim r4 As Range

    Set r = chartsSheet5.Range("B3:F23")
    Set r2 = chartsSheet2.Range("A57:L63")
    Set r3 = chartsSheet.Range("A60:F63")
    Set r4 = chartsSheet4.Range("A10:Q174")

    'Open a new mail item

    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(olMailItem)


    'Get its Word editor
    outMail.Display

    Set wEditor = outApp.ActiveInspector.WordEditor

    Dim thisRange As Range

    r.Copy
    wEditor.Range.PasteAndFormat wdChartPicture
    r2.Copy
    wEditor.Range(1, wEditor.Characters.Count).PasteAndFormat wdChartPicture
    r3.Copy
    wEditor.Range(2, wEditor.Characters.Count).PasteAndFormat wdChartPicture
    r4.Copy
    wEditor.Range(3, wEditor.Characters.Count).PasteAndFormat wdChartPicture

    End Sub


    Private Sub Insert_Resized_Chart(thisChartObject As ChartObject, newWidthCm As Single, newHeightCm As Single, wordRange As Object)


    'Arguments
    'thisChartObject - the ChartObject to be resized
    'newWidthCm - new width in centimeters
    'newHeighCm - new height in centimeters
    'wordRange - the current position in the email, as a Word.Range object

    Dim chartShape As Shape
    Dim currentWidth As Single
    Dim currentHeight As Single

    'Get the chart as a Shape

    Set chartShape = thisChartObject.Parent.Shapes(thisChartObject.Name)

    'Change chart to new dimensions

    With chartShape
    currentWidth = .Width
    currentHeight = .Height
    .Width = Application.CentimetersToPoints(newWidthCm)
    .Height = Application.CentimetersToPoints(newHeightCm)
    Debug.Print "Before: "; currentWidth; currentHeight, "After: "; .Width; .Height
    End With

    'Insert chart into email

    thisChartObject.Chart.ChartArea.Copy
    wordRange.PasteSpecial , , , , 4 'DataType:=wdPasteBitmap

    'Restore original dimensions

    With chartShape
    .Width = currentWidth
    .Height = currentHeight
    End With

    End Sub


    Tuesday, June 6, 2017 7:48 AM
  • Hi keirax3,

    You have created a new mail after putting charts to a mail. So you need deleted the code that re-created the new mail.

    Like this:

    Set r4 = chartsSheet4.Range("A10:Q174")
    'Open a new mail item
    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(olMailItem)
    'Get its Word editor
    outMail.Display
    Set wEditor = outApp.ActiveInspector.WordEditor
    Dim thisRange As Range
    r.Copy
    wEditor.Range.PasteAndFormat wdChartPicture

    Besides, I suggest you confirm location for inserting the table by moving selection so the table won’t cover the chart.

    Here is the example

    r.Copy
    wEditor.Application.Selection.EndKey Unit:=wdStory
    wEditor.Application.Selection.PasteAndFormat wdTableAppendTable   
    r2.Copy
    wEditor.Application.Selection.EndKey Unit:=wdStory
    wEditor.Application.Selection.PasteAndFormat wdTableAppendTable   
    r3.Copy
    wEditor.Application.Selection.EndKey Unit:=wdStory
    wEditor.Application.Selection.PasteAndFormat wdTableAppendTable   
    r4.Copy
    wEditor.Application.Selection.EndKey Unit:=wdStory
    wEditor.Application.Selection.PasteAndFormat wdTableAppendTable   

    Best Regards,

    Terry

    Wednesday, June 7, 2017 10:48 AM