Erro VBA: -2147188160 quando PasteSpecial a Shape

0

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 ...)

    
por Cromm 21.03.2018 / 13:55

0 respostas