vba - 使用 Powerpoint VBA 将 Excel 图表导出为图像

Question

我编写了以下代码，用于将“Chart1”从名为“Sheet1”的 Excel 工作表导出到创建的 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

我不使用 .Chart.Export 方法的原因是使用 Excel 2007 SP3 时得到的输出质量很差。

接下来我要做的是将 PowerPoint 中复制的图像另存为 .png，然后关闭 powerpoint 演示文稿而不保存更改。

请帮忙。

Answer 1

没关系，我已经弄清楚了:

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