none
How to resize the charts in outlook using vba macro RRS feed

  • Question

  • The following codes i wrote doesn't work so how do I able to resize the charts in outlook specifically?
    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
        'Required chart dimensions in the email
        
        'chartWidthCm = 12.93
       ' chartHeightCm = 7.95
        
        'Sheet1 contains the charts
        
        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")
        
       
    ' Only send the visible cells in the selection.
    
    Set rng = Sheets("Summary-Guidelines").Range("B1:D16").SpecialCells(xlCellTypeVisible)
    Set rng1 = Sheets("Summary-Guidelines").Range("B25:F27").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)
    
    
    
    
    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
    
    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(0)
     'Set wEditor = outApp.ActiveInspector.WordEditor
       ' Set wRange = wEditor.Application.ActiveDocument.Content
        
        
    With outMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = Sheets("Summary-Guidelines").Range("B3").Value & "  " & Sheets("Summary-Guidelines").Range("C3").Value & "  " & Sheets("Summary-Guidelines").Range("B4").Value & "  " & Sheets("Summary-Guidelines").Range("C4").Value & "  " & Format(Date, "dd/mm/yyyy")
        .HTMLBody = RangetoHTML(rng) & RangetoHTML0(rng1) & RangetoHTML1(rng2) & RangetoHTML2(rng3) & RangetoHTML3(rng4) '& Insert_Resized_Chart(chartsSheet)
        '.Body = chartsSheet2.ChartObjects("Chart 1")
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .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
        
        'Ensure subsequent inserts and pastes appear above automatic email signature
        
       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")
        chartObj.Height = 300
        chartObj.Width = 850
        wRange.Collapse 0 'Direction:=wdCollapseEnd
            End With
        
        
         With chartsSheet.ChartObjects("Chart 2").Parent
        Set chartObj = chartsSheet.ChartObjects("Chart 2")
        chartObj.Height = 200
        chartObj.Width = 400
     
        End With
        
        With chartsSheet.ChartObjects("Chart 3").Parent
        Set chartObj = chartsSheet.ChartObjects("Chart 3")
        wRange.InsertParagraphAfter
        wRange.InsertAfter "" '& Time & vbNewLine
        wRange.Collapse 0 'Direction:=wdCollapseEnd
        chartObj.Height = 200
        chartObj.Width = 400
        End With
              
       
        With chartsSheet.ChartObjects("Chart 1").Parent
        Set chartObj = chartsSheet.ChartObjects("Chart 1")
        chartObj.Height = 200
        chartObj.Width = 400
        End With
       
       
        With chartsSheet3.ChartObjects("Chart 1").Parent
        Set chartObj = chartsSheet3.ChartObjects("Chart 1")
        wRange.InsertParagraphAfter
        wRange.InsertAfter "" '& Time & vbNewLine
        wRange.Collapse 0 'Direction:=wdCollapseEnd
       chartObj.Height = 200
        chartObj.Width = 400
        End With

    Thursday, June 15, 2017 3:38 AM

Answers

  • I mean you need to resize the chart in Outlook after inserting them into mailbody.

    In your code, it could be:

    wEditor.Application.ActiveDocument.InlineShapes(1).Width = 850
    wEditor.Application.ActiveDocument.InlineShapes(1).Height = 300
    
    wEditor.Application.ActiveDocument.InlineShapes(2).Width = 400
    wEditor.Application.ActiveDocument.InlineShapes(2).Height = 200
    


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by keirax3 Friday, July 7, 2017 5:02 AM
    Thursday, June 29, 2017 8:57 AM
    Moderator

All replies

  • I want  table 1 (rng) to be position at the top before the charts and how do I resize charts where they have different sizes each specifically?
    
    Currently I have charts on top and tables below the charts
    
    
    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 rng2 As Range
        Dim rng3 As Range
        Dim rng4 As Range
    
        'Required chart dimensions in the email
    
        chartWidthCm = 12.93
        chartHeightCm = 7.95
    
        'Sheet1 contains the charts
    
        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 = Nothing
        Set rng2 = Nothing
        Set rng3 = Nothing
        Set rng4 = Nothing
    ' Only send the visible cells in the selection.
    
    Set rng = Sheets("Summary-Guidelines").Range("B3:F23").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)
    
    
    
    
    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
    
    Set outApp = CreateObject("Outlook.Application")
    Set outMail = outApp.CreateItem(0)
     'Set wEditor = outApp.ActiveInspector.WordEditor
       ' Set wRange = wEditor.Application.ActiveDocument.Content
    
    
    With outMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng) & RangetoHTML1(rng2) & RangetoHTML2(rng3) & RangetoHTML3(rng4) '& Insert_Resized_Chart(chartsSheet)
        ' In place of the following statement, you can use ".Display" to
        ' display the e-mail message.
        .Display
    End With
    On Error GoTo 0
    
    
    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
    
        '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.InsertBefore vbCr
         wRange.InsertAfter "" '& Time & vbNewLine
       wRange.Collapse 0 'Direction:=wdCollapseEnd
    
    
    
        Set chartObj = chartsSheet.ChartObjects("Chart 2")
        Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    
    
        Set chartObj = chartsSheet.ChartObjects("Chart 3")
        Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
        wRange.InsertParagraphAfter
        wRange.InsertAfter "" '& Time & vbNewLine
        wRange.Collapse 0 'Direction:=wdCollapseEnd
    
    
        Set chartObj = chartsSheet.ChartObjects("Chart 1")
        Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
    
    
        Set chartObj = chartsSheet3.ChartObjects("Chart 1")
        Insert_Resized_Chart chartObj, chartWidthCm, chartHeightCm, wRange
        wRange.InsertParagraphAfter
        wRange.InsertAfter "" '& Time & vbNewLine
        wRange.Collapse 0 'Direction:=wdCollapseEnd
    
    
    
    End Sub
    
    Function RangetoHTML(rng As Range)
    ' By Ron de Bruin.
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
    
        rng.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML = ts.ReadAll
        ts.Close
        RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    
    End Function
    Function RangetoHTML1(rng2 As Range)
    ' By Ron de Bruin.
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng2.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML1 = ts.ReadAll
        ts.Close
        RangetoHTML1 = Replace(RangetoHTML1, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    
    End Function
    Function RangetoHTML2(rng3 As Range)
    ' By Ron de Bruin.
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng3.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML2 = ts.ReadAll
        ts.Close
        RangetoHTML2 = Replace(RangetoHTML2, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    
    End Function
    
    Function RangetoHTML3(rng4 As Range)
    ' By Ron de Bruin.
        Dim fso As Object
        Dim ts As Object
        Dim TempFile As String
        Dim TempWB As Workbook
    
        TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    
        'Copy the range and create a new workbook to past the data in
        rng4.Copy
        Set TempWB = Workbooks.Add(1)
        With TempWB.Sheets(1)
            .Cells(1).PasteSpecial Paste:=8
            .Cells(1).PasteSpecial xlPasteValues, , False, False
            .Cells(1).PasteSpecial xlPasteFormats, , False, False
            .Cells(1).Select
            Application.CutCopyMode = False
            On Error Resume Next
            .DrawingObjects.Visible = True
            .DrawingObjects.Delete
            On Error GoTo 0
        End With
    
        'Publish the sheet to a htm file
        With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             Filename:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
             Source:=TempWB.Sheets(1).UsedRange.Address, _
             HtmlType:=xlHtmlStatic)
            .Publish (True)
        End With
    
        'Read all data from the htm file into RangetoHTML
        Set fso = CreateObject("Scripting.FileSystemObject")
        Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
        RangetoHTML3 = ts.ReadAll
        ts.Close
        RangetoHTML3 = Replace(RangetoHTML3, "align=center x:publishsource=", _
                              "align=left x:publishsource=")
    
        'Close TempWB
        TempWB.Close savechanges:=False
    
        'Delete the htm file we used in this function
        Kill TempFile
    
        Set ts = Nothing
        Set fso = Nothing
        Set TempWB = Nothing
    
    End Function
    
    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



    Wednesday, June 14, 2017 1:12 AM
  • Please help me, I needed to find the solution urgently
    Wednesday, June 14, 2017 6:50 AM
  • Hi keirax3,

    you had mentioned that ,"I want  table 1 (rng) to be position at the top before the charts and how do I resize charts where they have different sizes each specifically?"

    I can see in your code that first you try to add the chart and then you try to add the Wrange.

    so you just need to add the rng before the chart.

    just put that line of code before the line which adds the chart.

    I can also see that you have the sub named 'Insert_Resized_Chart' to set the height and width of the chart.

    is it not working?

    whenever you call this sub for resizing the chart you can give the desire height and width to resize it.

    try to make the changes in your code and check whether it is working or not.

    it is better if you post your Excel file with dummy data in it.

    so that we can try to make test with that file using code above.

    let us know about your testing result, so that we can try to provide you further suggestions, if needed.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    Thursday, June 15, 2017 6:56 AM
    Moderator
  • Thanks for the reply but the following solution you suggest does not work.

    I have included the excel sheet and model outlook email that needs to look like that as an example. Thanks

    https://drive.google.com/folderview?id=0ByC7glOs6KMLc3JPZEpFOUd3ZUE

    Thursday, June 15, 2017 8:12 AM
  • Hi keirax3,

    you had mentioned that ,"I want  table 1 (rng) to be position at the top before the charts and how do I resize charts where they have different sizes each specifically?"

    I can see in your code that first you try to add the chart and then you try to add the Wrange.

    so you just need to add the rng before the chart.

    just put that line of code before the line which adds the chart.

    I can also see that you have the sub named 'Insert_Resized_Chart' to set the height and width of the chart.

    is it not working?

    whenever you call this sub for resizing the chart you can give the desire height and width to resize it.

    try to make the changes in your code and check whether it is working or not.

    it is better if you post your Excel file with dummy data in it.

    so that we can try to make test with that file using code above.

    let us know about your testing result, so that we can try to provide you further suggestions, if needed.

    Regards

    Deepak


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.


    How do I add the rng before that chart line? Example?

    Could u provide an example on how to resize like for example, resize

    Set chartObj = chartsSheet2.ChartObjects("Chart 1") <-

    Thursday, June 15, 2017 9:51 AM
  • Hello,

    Do you get any error?

    The code could resize the chart in Excel. Do you want to resize the chart in Outlook body? You could resize the chart in Excel and copy it into clipboard and paste into Outlook body using ChartObject.Copy Method (Excel) or ChartObject.CopyPicture Method (Excel)

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, June 16, 2017 3:33 AM
    Moderator
  • 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
        
        'chartWidthCm = 12.93
       ' chartHeightCm = 7.95
        
        
        
        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%20Management%20Documents%2F02%2E%20Project%20Progress%20Reports%2FTRAVEL%20%2D%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
    
    How to resize the charts in excel?
    Wednesday, June 21, 2017 4:40 AM
  • 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%20Management%20Documents%2F02%2E%20Project%20Progress%20Reports%2FTRAVEL%20%2D%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
    My codes doesnt work
    Wednesday, June 21, 2017 7:45 AM
  • Hello,

    The following code are resizing the chart in Excel.

    chartObj.Height = 320
    chartObj.Width = 420

    Do you get any error when you run the macro above?

    If the code above could not resize the chart, I suggest you create a simple macro to test the code snippet used to resize the chart. Then debug your current macro, you may comment out parts by parts to check what causes the issue.

    Regards,

    Celeste  


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Wednesday, June 21, 2017 8:40 AM
    Moderator
  • It become like this

    instead of this which I want:

    • Edited by keirax3 Wednesday, June 21, 2017 9:13 AM
    Wednesday, June 21, 2017 9:11 AM
  • 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%20Management%20Documents%2F02%2E%20Project%20Progress%20Reports%2FTRAVEL%20%2D%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
    My codes doesnt work
    Thursday, June 22, 2017 1:31 AM
  • Hello,

    I suggest you check if the chart is successfully resized in Excel.

    If it is resized in Excel but fail in Outlook mail body, please debug your function Insert_Resized_Chart.

    You could visit Chapter 17: Working with Item Bodies to see how to work with mail body.

    Besides, you could output the correct HTMLbody in Outlook, and compare your HTML string when you create the mailitem.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Friday, June 23, 2017 4:38 AM
    Moderator
  • It is able to resize in excel and not in email

    For Insert_Resized_Chart, I only add this code. And also how to align the charts so chart 1 is at one line

    and chart 2 and 3 is next line

      Private Sub Insert_Resized_Chart(thisChartObject As ChartObject, wordRange As Object)
    
        thisChartObject.Chart.ChartArea.Copy
        wordRange.PasteSpecial , , , , 4 'DataType:=wdPasteBitmap
    End Sub

    Friday, June 23, 2017 9:41 AM
  • Hello,

    After comparing the HTML body, all the charts are resized by Word Editor when pasting. The HTML for the first big chart is changed into width:468.75pt;height:165.75pt . There is no big difference for rest charts.

    Paste manually:
    </v:shapetype><v:shape id="Chart_x0020_1" o:spid="_x0000_i1027" type="#_x0000_t75" style='width:850.5pt;height:300.75pt;visibility:visible' 
    
    
    Paste using Range.PasteSpecial 
    
    </v:shapetype><v:shape id="Chart_x0020_1" o:spid="_x0000_i1025" type="#_x0000_t75" style='width:468.75pt;height:165.75pt;visibility:visible' o:gfxdata="UEsDBBQABgAIAAAAIQD1avy5IAEAAF4CAAATAAAAW0NvbnRlbnRfVHlwZXNdLnhtbIySy07DMBBF

    So you need to resize the chart or picture in Word Editor instead of Excel.

    To resize the charts in Word Editor, you could use something like:

    Dim myInspector As Inspector
    Set myInspector = mymail.GetInspector
    Dim wDoc As Word.Document
    Dim wRng As Word.Range
    Set wDoc = myInspector.WordEditor
    Set wRng = wDoc.Application.Selection.Range
    
    wRng.PasteSpecial
    wDoc.InlineShapes(1).Width = 850
    wDoc.InlineShapes(1).Height = 300

    The pasted charts or pictures are inlineshapes in the Word Editor.

    Regards,

    Celeste


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    Monday, June 26, 2017 9:38 AM
    Moderator
  • It said user defined type not defined? Could you give me an example specifically on where to insert the code at?
    Wednesday, June 28, 2017 9:36 AM
  • I mean you need to resize the chart in Outlook after inserting them into mailbody.

    In your code, it could be:

    wEditor.Application.ActiveDocument.InlineShapes(1).Width = 850
    wEditor.Application.ActiveDocument.InlineShapes(1).Height = 300
    
    wEditor.Application.ActiveDocument.InlineShapes(2).Width = 400
    wEditor.Application.ActiveDocument.InlineShapes(2).Height = 200
    


    MSDN Community Support
    Please remember to click "Mark as Answer" the responses that resolved your issue, and to click "Unmark as Answer" if not. This can be beneficial to other community members reading this thread. If you have any compliments or complaints to MSDN Support, feel free to contact MSDNFSF@microsoft.com.

    • Marked as answer by keirax3 Friday, July 7, 2017 5:02 AM
    Thursday, June 29, 2017 8:57 AM
    Moderator