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

Answer 2

我想出了如何提高Charts.Export输出的质量。 图像的大小与图表的缩放比例有关。

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