Eu tenho um procedimento de VBA que chama outro procedimento (addChart (cht, PptApp, oPres)), para adicionar gráficos a uma apresentação de powerpoint. Quando eu executo o código completo, o procedimento cria um novo ppt e cola os gráficos um por um, mas chegando a um gráfico, tenho o seguinte erro:
Erro de tempo de execução '-2147188160 (80048240)'
O método 'PasteSpecial' do objeto 'Shapes' falhou
cht.Select
ActiveChart.ChartArea.Copy
PptApp.Visible = msoTrue
Set PPShape = activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture)
With PPShape
.Height = 440
.Width = 790
End With
Com a linha problemática Set PPShape = activeSlide.Shapes.PasteSpecial (DataType: = ppPasteMetafilePicture) .
No entanto, se eu executar o código várias vezes, será sempre um gráfico diferente que receberá o erro, enquanto os anteriores são colados sem qualquer problema ...
Public Sub addChart(ByVal cht As Excel.ChartObject, ByRef PptApp, ByRef oPres)
Dim shpCurrShape As Object
Dim activeSlide As PowerPoint.Slide
Dim PptDoc
If cht.Name <> "Waterfall1" And cht.Name <> "Waterfall2" Then
'Add a new slide where we will paste the chart
PptApp.ActivePresentation.Slides.Add PptApp.ActivePresentation.Slides.Count + 1, ppLayoutText
PptApp.ActiveWindow.View.GotoSlide PptApp.ActivePresentation.Slides.Count
Set activeSlide = PptApp.ActivePresentation.Slides(PptApp.ActivePresentation.Slides.Count)
'Copy the logo and paste it
Worksheets("Page").Shapes("logo_medium").Copy
Set PPShape = activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture)
With PPShape
.Top = 30
.Left = 40
End With
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
PptApp.Visible = msoTrue
Set PPShape = activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture)
With PPShape
.Height = 440
.Width = 790
End With
'Set the header
PptApp.Visible = msoTrue
With activeSlide
'expression.AddTextbox(Orientation, Left, Top, Width, Height)
Set shpCurrShape = .Shapes.AddTextbox(1, 120, 30, 654, 45)
With shpCurrShape
With .TextFrame.TextRange
'~~> Set text here
.Text = "Unit: " + Cells(1, 4).Value + vbCrLf + "Month: " + Cells(1, 11)
'~~> Alignment
.ParagraphFormat.Alignment = 3
'~~> Working with font
With .Font
.Bold = msoTrue
.Size = 16
.Color = RGB(0, 0, 0)
End With
End With
End With
End With
'Set the title of the slide the same as the title of the chart
'activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'activeSlide.Shapes(1).TextFrame.HorizontalAnchor = msoAnchorCenter
'Adjust the positioning of the Chart on Powerpoint Slide
PptApp.Visible = msoTrue
PptApp.Visible = msoTrue
PptApp.ActiveWindow.Selection.ShapeRange.Left = 15
PptApp.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
With oPres.PageSetup
PPShape.Left = (.SlideWidth / 2) - (PPShape.Width / 2)
PPShape.Top = (.SlideHeight / 2) - (PPShape.Height / 2) + 25
End With
End If
End Sub
Editar: parece que também ocorre ao tentar colar o logotipo, cada execução recebo o erro em uma pasta de objeto diferente (às vezes após a primeira colagem do logotipo, às vezes após o 20º gráfico ...)