如何从 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