1

У меня есть процедура VBA, которая вызывает другую процедуру (addChart (cht, PptApp, oPres)), чтобы добавить диаграммы к презентации PowerPoint. Когда я запускаю полный код, процедура создает новый ppt и вставляет диаграммы один за другим, но при поступлении на график появляется следующая ошибка:

Ошибка времени выполнения '-2147188160 (80048240)'

Сбой метода 'PasteSpecial' объекта 'Shapes'

cht.Select
ActiveChart.ChartArea.Copy
PptApp.Visible = msoTrue
Set PPShape = activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture)

            With PPShape
                .Height = 440
                .Width = 790
            End With

С помощью Set PPShape = activeSlide.Формы.PasteSpecial(DataType:= ppPasteMetafilePicture) проблемная строка.

Однако, если я буду запускать код несколько раз, это всегда будет другая диаграмма, которая получит ошибку, в то время как предыдущие вставляются без проблем ...

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

Изменить: кажется, что это также происходит при попытке вставить логотип, при каждом запуске я получаю ошибку при вставке другого объекта (иногда после самой первой вставки логотипа, иногда после 20-го графика ...)

|источник

0