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

我有下面的代码，我写了导出“Chart1”从一个名为“Sheet1”的Excel工作表到一个新的幻灯片在一个创build的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，然后closuresPowerPoint演示文稿而不保存更改。

请协助。

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