如何从Excel复制多个图表并将其嵌入到PPT?

Question

我正在尝试将多个图表从 excel 中的工作表复制并粘贴到 PowerPoint 中的幻灯片中。我有：

Public Sub CreateManagmentPres()
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ppTextbox As PowerPoint.Shape
Set PPApp = New PowerPoint.Application
PPApp.Visible = True
PPApp.Activate
Set PPPres = PPApp.Presentations.Add
'Summary of Assumptions (Cont'd)
Set PPSlide = PPPres.Slides.Add(6, ppLayoutTitleOnly)
PPSlide.Select
PPSlide.Shapes(1).TextFrame.TextRange.Text = "Summary of Assumptions (Cont'd)"
ActiveWorkbook.Sheets("Case Summary").ChartObjects("Chart Rev").Copy
With PPPres.Slides(6).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, _
Link:=msoTrue)
End With
PPSlide.Shapes(2).Top = 70
PPSlide.Shapes(2).Left = 11
ActiveWorkbook.Sheets("Case Summary").ChartObjects("Chart Lev").Copy
With PPPres.Slides(6).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, _
Link:=msoTrue)
End With
PPSlide.Shapes(3).Top = 70
PPSlide.Shapes(3).Left = 370

这将返回"形状(未知成员(。无效的请求。指定的数据类型不可用。 与With PPPres.Slides(6).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, _ Link:=msoTrue)相关

我看到一个相关的帖子将我的代码更改为：

Set PPSlide = PPPres.Slides.Add(6, ppLayoutTitleOnly)
PPSlide.Select
PPSlide.Shapes(1).TextFrame.TextRange.Text = "Summary of Assumptions (Cont'd)"

ActiveWorkbook.Sheets("Case Summary").ChartObjects("Chart Rev").ChartArea.Copy
With PPPres.Slides(6).Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoTrue)
'~~> Rest of your code here
End With
PPSlide.Shapes(2).Top = 70
PPSlide.Shapes(2).Left = 11

现在我得到"对象不支持此属性或方法"：

ActiveWorkbook.Sheets("Case Summary").ChartObjects("Chart Rev").ChartArea.Copy

Answer 1

尝试使用此代码

Function PasteChartIntoSlide(theSlide As Object) As Object
Sleep 100
On Error Resume Next
theSlide.Shapes.Paste.Select
PPT.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
End Function
Function CopyChartFromExcel(theSlide As Object, cht As Chart) As Object
cht.CopyPicture Appearance:=xlScreen, Format:=xlPicture, Size:=xlScreen
End Function
Function PositionChart(leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
Sleep 50
PPT_pres.Windows(1).Selection.ShapeRange.Left = leftPos
PPT_pres.Windows(1).Selection.ShapeRange.Top = rightPos
PPT_pres.Windows(1).Selection.ShapeRange.Width = widthPos
PPT_pres.Windows(1).Selection.ShapeRange.Height = heightPos
End Function

Function CopyPasteChartFull(Sld As Integer, cht As Chart, leftPos As Integer, rightPos As Integer, widthPos As Integer, heightPos As Integer) As Object
If PPT Is Nothing Then Exit Function
If PPT_pres Is Nothing Then Exit Function
Dim mySlide As Object
Dim myShape As Object
PPT_pres.Slides(Sld).Select 'Pointless line, just lets the user see what is happening
Set mySlide = PPT_pres.Slides(Sld)
With mySlide
.Select
'copy chart
CopyChartFromExcel mySlide, cht
'Paste chart
PasteChartIntoSlide mySlide
'Position Chart
PositionChart leftPos, rightPos, widthPos, heightPos
End With
'Clear The Clipboard
Application.CutCopyMode = False
End Function