☰

当 PasteSpecial 为 Shape 时，VBA 出现错误：-2147188160

tag-icon • tag-icon microsoft-excel vba microsoft-powerpoint charts
当 PasteSpecial 为 Shape 时，VBA 出现错误：-2147188160

我有一个 vba 过程，它调用另一个过程 (addChart(cht, PptApp, oPres))，以将图表添加到 powerpoint 演示文稿中。当我运行完整代码时，该过程会创建一个新的 ppt 并逐个粘贴图表，但到达图表时，我出现以下错误：

运行时错误‘-2147188160 (80048240)’

对象“Shapes”的方法“PasteSpecial”失败

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

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

随着设置 PPShape = activeSlide.Shapes.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 个图表之后......）

答案1

我遇到了一个问题，我不确定它是否与您报告的问题相同。我认为我现在已经通过在每次粘贴操作之前添加 Sleep 100 和 DoEvents 解决了这个问题。

相关内容