PDA

View Full Version : How to resize the charts in outlook using vba macro



keirax3
06-21-2017, 06:42 PM
My code doesnt work. Help!! Attach is the example that should be the outcome and current outcome and the link for excel workbook



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
Dim rng As Range
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rng5 As Range
'Required chart dimensions in the email


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

Set rng = Sheets("Summary-Guidelines").Range("B7:E12").SpecialCells(xlCellTypeVisible)
Set rng1 = Sheets("Summary-Guidelines").Range("B23:F36").SpecialCells(xlCellTypeVisible)
Set rng2 = Sheets("Test Execution (Manual)").Range("A57:L63").SpecialCells(xlCellTypeVisible)
Set rng3 = Sheets("Defects").Range("A60:F63").SpecialCells(xlCellTypeVisible)
Set rng4 = Sheets("JIRA_List").Range("A10:P175").SpecialCells(xlCellTypeVisible)


Set rng5 = Sheets("Summary-Guidelines").Range("Overall_Test_Status").SpecialCells(xlCellTypeVisible)




If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected. " & _
vbNewLine & "Please correct and try again.", vbOKOnly
Exit Sub
End If


With Application
.EnableEvents = False
.ScreenUpdating = False
End With


Dim strbody As String
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)

strbody = "<HTML><BODY>"
strbody = strbody & "<A href=https://teams.income.com.sg/sites/improject/BI/eCommerce/_layouts/15/start.aspx#/Project%20Management%20Documents/Forms/AllItems.aspx?RootFolder=%2Fsites%2Fimproject%2FBI%2FeCommerce%2FProject%20 Management%20Documents%2F02%2E%20Project%20Progress%20Reports%2FTRAVEL%20%2 D%20UAT%20%2D%20Cycle%201%20%2D%20Progress%20Report&FolderCTID=0x012000EAB27D1B6BF8064B876182D9D0B475F7&View=%7B6FB45BFE%2D53C9%2D4F12%2DB878%2D4D6F496D3AE8%7D>URL Text</A>"
strbody = strbody & "</BODY></HTML>"

With outMail
.To = ""
.CC = ""
.BCC = ""
.Subject = Sheets("Summary-Guidelines").Range("C4").Value & " - " & Sheets("Summary-Guidelines").Range("C5").Value & " - " & "Status as of " & Format(Date, "dd/mm/yyyy")
.HTMLBody = RangetoHTML(rng) & RangetoHTML4(rng5) & RangetoHTML0(rng1) & strbody & RangetoHTML1(rng2) & RangetoHTML2(rng3) & RangetoHTML3(rng4) '& Insert_Resized_Chart(chartsSheet)

.Display
End With




With Application
.EnableEvents = True
.ScreenUpdating = True
End With


Set outMail = Nothing
Set outApp = Nothing

Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
Set wEditor = outApp.ActiveInspector.WordEditor
Set wRange = wEditor.Application.ActiveDocument.Content

wRange.Collapse 1 'Direction:=wdCollapseStart

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

With chartsSheet2.ChartObjects("Chart 1").Parent
Set chartObj = chartsSheet2.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
chartObj.Height = 200
chartObj.Width = 450
wRange.Collapse 0 'Direction:=wdCollapseEnd
End With

With chartsSheet.ChartObjects("Chart 2").Parent
Set chartObj = chartsSheet.ChartObjects("Chart 2")

Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
chartObj.Height = 300
chartObj.Width = 650
End With

With chartsSheet.ChartObjects("Chart 3").Parent
Set chartObj = chartsSheet.ChartObjects("Chart 3")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter ""
wRange.Collapse 0 'Direction:=wdCollapseEnd

chartObj.Height = 320
chartObj.Width = 420
End With

With chartsSheet.ChartObjects("Chart 1").Parent
Set chartObj = chartsSheet.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
chartObj.Height = 300
chartObj.Width = 650
End With

With chartsSheet3.ChartObjects("Chart 1").Parent
Set chartObj = chartsSheet3.ChartObjects("Chart 1")
Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
wRange.InsertParagraphAfter
wRange.InsertAfter "" '& Time & vbNewLine
wRange.Collapse 0 'Direction:=wdCollapseEnd
chartObj.Height = 320
chartObj.Width = 420
End With

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


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

End Sub


1956319564