Копирование из Excel в Powerpoint Ошибка

Question

Снова с помощью ресурсов вида вокруг stackoverflow я использовал следующий код для копирования информации из Excel 2010 в слайды Powerpoint 2010. Я повторяю код в середине примерно 20 раз для своих слайдов.

Я начинаю получить сообщение прерывисто

Run-time error -2147417851 (80010105) method 'pastespecial' of object 'shapes' failed 

на этой линии:

Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse) 

Вот остальная часть кода:

Sub PPTReport() 

Dim PPApp As PowerPoint.Application 
Dim PPSlide As PowerPoint.Slide 
Dim PPPres As PowerPoint.Presentation 
Set PPApp = CreateObject("Powerpoint.Application") 
Dim SlideNum As Integer 
Dim wbk As Workbook 
'Dim ppShape As PowerPoint.Shape 
Dim ppShape As Object 

Set XLApp = GetObject(, "Excel.Application") 

''define input Powerpoint template 
    Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String 
''# Change "strPresPath" with full path of the Powerpoint template 
strPresPath = ThisWorkbook.Path & "\template\template.ppt" 
''# Change "strNewPresPath" to where you want to save the new Presentation to be created 
strNewPresPath = ThisWorkbook.Path & "\electra_status_report-" & Format(Date, "yyyy-mm-dd") & ".ppt" 
    Set PPPres = PPApp.Presentations.Open(strPresPath) 
    PPPres.Application.Activate 


PPApp.Visible = True 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''define destination slide 
    SlideNum = 1 
    PPPres.Slides(SlideNum).Select 
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex) 

''define source sheet 
strFirstFile = ThisWorkbook.Path & "\workstreams\ws1.xlsx" 
Set wbk = Workbooks.Open(strFirstFile) 

wbk.Sheets("WS1").Activate 
    Cells(1, 1).Activate 
'copy/paste from 
    XLApp.Range("WS1Dash").Copy 
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse) 

'place size and shape 72 ppi 
ppShape.Width = 718 
ppShape.Left = 1 
ppShape.Top = 16 

    PPPres.Application.Activate 
    wbk.Sheets("WS1").Activate 
    Cells(1, 1).Copy 
wbk.Close savechanges:=False 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''define destination slide 
    SlideNum = 2 
    PPPres.Slides(SlideNum).Select 
    Set PPSlide = PPPres.Slides(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex) 

''define source sheet 
strFirstFile = ThisWorkbook.Path & "\workstreams\ws2.xlsx" 
Set wbk = Workbooks.Open(strFirstFile) 

wbk.Sheets("WS2").Activate 
    Cells(1, 1).Activate 

'copy/paste from 
    XLApp.Range("WS2Dash").Copy 
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse) 

'place size and shape 72 ppi 
ppShape.Width = 718 
ppShape.Left = 1 
ppShape.Top = 16 

    PPPres.Application.Activate 
    wbk.Sheets("WS2").Activate 
    Cells(1, 1).Copy 
wbk.Close savechanges:=False 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' 
' Sheets("Dashboard").Activate 
' Close presentation 
    PPPres.SaveAs strNewPresPath 
    PPPres.Close 
' Quit PowerPoint 
    PPApp.Quit 

' Clean up 
Set PPSlide = Nothing 
Set PPPres = Nothing 
Set PPApp = Nothing 

    AppActivate "Microsoft Excel" 
MsgBox "Presentation Created", vbOKOnly + vbInformation 

End Sub 

Любые мысли о том, как решить эта ошибка?

Answer 1

Проблема, с которой вы сталкиваетесь, заключается в том, что копирование занимает время, а следующая строка выполняется, и она не находит ничего в буфере обмена для вставки.

Два способа справиться с этой проблемой

Way 1

XLApp.Range("WS1Dash").Copy 
DoEvents 
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse) 

Way 2

XLApp.Range("WS1Dash").Copy 
Wait 2 
Set ppShape = PPSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, Link:=msoFalse) 

и вставить в нижней части процедуры

Private Sub Wait(ByVal nSec As Long) 
    nSec = nSec + Timer 
    While nSec > Timer 
     DoEvents 
    Wend 
End Sub 

Лемм знать, если это не поможет ...

Answer 2

У меня была та же проблема, и это произошло, как я пытался экспортировать из Excel в PowerPoint без ссылки PowerPoint, используя его в качестве объекта. Трудная вещь заключалась в том, что иногда это сработало, иногда это не так. Поэтому после некоторого тестирования я узнал, что это зависит от состояния PowerPoint View, если он показывает Thumbnails или обычный слайд-просмотр.

Чтобы исправить это, перед вставкой установите ViewType как обычно.

PPAP.ActiveWindow.ViewType = ppViewNormal 

или

PPAP.ActiveWindow.ViewType = 9 

РРАР обозначает объект PowerPoint Application.