Question

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

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

2 个答案: