How to resize table and put the charts and tables in a single email as well as adding texts using Excel Macro

[keirax3x3]

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? This is the expected result:

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
'Dim objSel As Word.Selection 'we will put the items that we want in the current word selection
'Dim myShape As Object'



'wRange.InsertAfter "Text at top" & vbNewLine




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






'Paste as picture in sheet and cut immediately
'Dim p As Picture
'Set p = ActiveSheet.Pictures.Paste
'p.Cut


'Open a new mail item
'Dim outApp As Outlook.Application'
Set outApp = CreateObject("Outlook.Application")
'Dim outMail As Outlook.MailItem'
Set outMail = outApp.CreateItem(olMailItem)


'Get its Word editor
outMail.Display
'Dim wEditor As Word.Document'
Set wEditor = outApp.ActiveInspector.WordEditor
'Set objSel = wEditor.Windows(1).Selection
'Dim shp As Object
'For Each shp In wEditor.InlineShapes
'shp.ScaleHeight = 120
'shp.ScaleWidth = 350
Dim thisRange As Range
Set wRange = wEditor.Application.ActiveDocument.Content

wRange.InsertAfter "Text below Chart3 " & Time & vbNewLine
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








'To paste as picture
'wEditor.Range.Paste;


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



'2
End Sub