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
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