Export Excel Charts as Images using Powerpoint VBA

Question

I have the below code that I have written to export "Chart1" from an Excel sheet called "Sheet1" to a new slide in a created instance of powerpoint:

Sub ChartsToPowerPoint()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide
    Dim pptSlideCount As Integer
    Dim ws As Worksheet
    Dim intChNum As Integer
    Dim objCh As Object

    'Open PowerPoint and create a new presentation.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add

    'Set the chart and copy it to a new ppt slide
    Set objChart = Worksheets("Sheet1").ChartObjects("Chart 1").Chart
    objChart.ChartArea.Copy
    Set pptSlide = pptPres.Slides.Add(pptSlideCount + 1, ppLayoutBlank)
    pptSlide.Shapes.PasteSpecial ppPasteJPG

    'Format the picture size/position.
    For j = 1 To pptSlide.Shapes.Count
        With pptSlide.Shapes(j)
            If .Type = msoPicture Then
                .Top = 87
                .Left = 33
                .Height = 422
                .Width = 646
            End If
        End With
    Next j

    pptApp.Visible = True

    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub

The reason I am not using .Chart.Export method is because of the poor quality output that I am getting when using Excel 2007 SP3.

What I am looking to do next is to save the copied image from PowerPoint as a .png and then close the powerpoint presentation without saving changes.

Please assist.

Answer 1

Never mind I figured it out:

Sub ChartsToPowerPoint()

    Dim pptApp As PowerPoint.Application
    Dim pptPres As PowerPoint.Presentation
    Dim pptSlide As PowerPoint.Slide

    'Open PowerPoint and create an invisible new presentation.
    Set pptApp = New PowerPoint.Application
    Set pptPres = pptApp.Presentations.Add(msoFalse)

    'Set the charts and copy them to a new ppt slide
    'I could have also used for every chart object line
    'but I have only 2 charts

    Set objChart = Worksheets("Sheet1").ChartObjects("Chart 1").Chart
    objChart.ChartArea.Copy
    Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
    pptSlide.Shapes.Paste

    Set objChart = Worksheets("Sheet1").ChartObjects("Chart 2").Chart
    objChart.ChartArea.Copy
    pptSlide.Shapes.Paste

    'Save Images as png
    path = "C:\Users\xyz\Desktop\"

    For j = 1 To pptSlide.Shapes.Count
        With pptSlide.Shapes(j)
        .Export path & j & ".png", ppShapeFormatPNG
        End With
    Next j

    pptApp.Quit

    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing

End Sub

Answer 2

I figured out how to improve the quality of Charts.Export output. The image's size is linked to the zoom of the chart's sheet.

Sub ExportChart()
    Application.ScreenUpdating = False
    ActiveWindow.Zoom = 275
    Dim path1 As String
    path1 = "C:\path\path\path\image.png"


    ActiveSheet.ChartObjects("chart name").Activate
    ActiveChart.Export FileName:=path1, FilterName:="PNG"
    ActiveWindow.Zoom = 47

    Application.ScreenUpdating = True
End Sub