使用 Powerpoint VBA 将 Excel 图表导出为图像
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/25353221/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Export Excel Charts as Images using Powerpoint VBA
提问by CaptainABC
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:
我编写了以下代码，用于将名为“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
The reason I am not using .Chart.Exportmethod is because of the poor quality output that I am getting when using Excel 2007 SP3.
我不使用.Chart.Export方法的原因是因为我在使用 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.
我接下来要做的是将 PowerPoint 中复制的图像另存为 .png，然后关闭 powerpoint 演示文稿而不保存更改。
Please assist.
请协助。
回答by CaptainABC
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
回答by strAtus
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.
我想出了如何提高 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
