通过vba从excel粘贴到powerpoint时出现ActiveX错误

我正在开发一个宏，该宏基于输入excel的数据构建简报模板

我收到的错误信息： ActiveX组件无法创建对象或返回对此对象的引用（错误429）

由于它们是需要在多张幻灯片上创建的各种对象，因此我编写了一个子例程，可以根据excel文件中设置的一些设置对每个对象重复使用

这是运行的子例程

它在粘贴函数本身上出错，将鼠标悬停在该行中的变量上会给出所需的正确值。我已经测试了它自己，它的工作与它接收的值很好。我还进行了检查，以确保这些值是从excel复制的，并且是正确的

我在这件事上不知所措

Private Sub AddShape(vSummary As Boolean, vSheet As String, vRange As String, vFirstSlide As Integer, vLastSlide As Integer, vTop As Double, vLeft As Double)
Dim Sld As Integer
'Copy specified cells
    WB.Sheets(vSheet).Range(vRange).Copy
'Paste to first required slide for the specified cell group
    ActivePresentation.Slides(vFirstSlide).Shapes.PasteSpecial (ppPasteEnhancedMetafile)
'Set the specified top position
    ActiveWindow.Selection.ShapeRange.Top = (vTop * vDPI)
'Center everything before we begin
    ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
    ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
'Determine if Left position needs set'
    If vLeft Then
       ActiveWindow.Selection.ShapeRange.Left = (vLeft * vDPI)
    End If
'If contents is a Summary
    If vSummary Then
'While we still have it selected
        With ActiveWindow.Selection.ShapeRange
            .LockAspectRatio = msoTrue  'Lock Aspect Ratio
            .Width = (10 * vDPI)        'Reszie to fit slide'
            .Ungroup                    'Ungroup to make it easier to edit manually'
        End With
    Else
        'Ungroup to make it easier to edit manually then copy it to paste it to all the required slides
        ActiveWindow.Selection.ShapeRange.Ungroup.Copy
        'We pasted one already so we need to set the new first slide to the second in the series of slides to recieve the current content
        vFirstSlide = vFirstSlide + 1
        'For the specified remaineder of the slides we paste the contents we just copied.
        'NOTE: this only works if the contents are to be placed on a concurrent set of slides. this will break if the content you are adding requires random placements in the templates
        For Sld = vFirstSlide To vLastSlide
            ActivePresentation.Slides(Sld).Shapes.Paste
        Next Sld
    End If
End Sub

我正在从以下子程序调用

Sub BuildTemplate()

'Set Global Variables
Set WB = Workbooks("tool.xlsm")             'Set this to the name of the excel file
Set Settings = WB.Sheets("SETTINGS")        'Set this to the name of the settings tab
Set Build = WB.Sheets("BUILD")              'Set this to the name of the build tab
Set Entry = WB.Sheets("ENTRY")              'Set this to the name of the entry tab

    vDPI = Settings.Cells(2, "B").Value

'Adjust column sizes
    Build.Columns(2).AutoFit
    Build.Columns(4).AutoFit
    Build.Columns(6).AutoFit
    Build.Columns(8).AutoFit

'Create Template Files
MoveFiles
'Open newly created Template File
Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:=vNewPrimaryTemplatePath
'Add Title Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E2")), CInt(Settings.Range("E3")), CInt(Settings.Range("E4")), CDbl(Settings.Range("E5")), CDbl(Settings.Range("E6")))

'Add Delivery Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E9")), CInt(Settings.Range("E10")), CInt(Settings.Range("E11")), CDbl(Settings.Range("E12")), CDbl(Settings.Range("E13")))

'Add Address Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E16")), CInt(Settings.Range("E17")), CInt(Settings.Range("E18")), CDbl(Settings.Range("E19")), CDbl(Settings.Range("E20")))

'Add Items
Call AddShape(False, "BUILD", CStr(Settings.Range("H2")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H12")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H3")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H13")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H4")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H14")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H5")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H15")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H6")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H12")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H7")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H13")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H8")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H14")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H9")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H15")), CDbl(Settings.Range("H11")))

'Add Summaries
    AddSummary

'Save & Close
    ActivePresentation.SaveAs Filename:=vNewPrimaryTemplatePath, FileFormat:=ppSaveAsDefault
    ActivePresentation.Close

End Sub

Private Sub AddShape(vSummary As Boolean, vSheet As String, vRange As String, Optional vFirstSlide As Integer, Optional vLastSlide As Integer, Optional vTop As Double, Optional vLeft As Variant = "Centered")
Dim Sld As Integer
Dim oSlide As Slide
Dim oShape As Object

'Copy specified cells
    WB.Sheets(vSheet).Range(vRange).Copy
'Paste to first required slide for the specified cell group
Set oSlide = PPT.ActivePresentation.Slides(vFirstSlide)
Set oShape = oSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
'Center everything before we begin
    oShape.Align msoAlignCenters, True
    oShape.Align msoAlignMiddles, True
'Set the specified top position
    oShape.Top = (vTop * vDPI)
'Determine if Left position needs set'
    If vLeft = "Centered" Then
        oShape.Align msoAlignCenters, True
    Else
        oShape.Left = (vLeft * vDPI)
    End If
'If contents is a Summary
    If vSummary Then
'While we still have it selected
        With oShape
            .LockAspectRatio = msoTrue  'Lock Aspect Ratio
            .Width = (10 * vDPI)        'Reszie to fit slide'
            .Ungroup                    'Ungroup to make it easier to edit manually'
        End With
    Else
        'Ungroup to make it easier to edit manually then copy it to paste it to all the required slides
        oShape.Ungroup.Copy
        'We pasted one already so we need to set the new first slide to the second in the series of slides to recieve the current content
        vFirstSlide = vFirstSlide + 1
        'For the specified remaineder of the slides we paste the contents we just copied.
        'NOTE: this only works if the contents are to be placed on a concurrent set of slides. this will break if the content you are adding requires random placements in the templates
        For Sld = vFirstSlide To vLastSlide
            PPT.ActivePresentation.Slides(Sld).Shapes.Paste
        Next Sld
    End If

End Sub

---

我设法把一切都弄明白了，使它运转良好

这是一个范围问题，子流程中的ActivePresentation无法访问powerpoint应用程序。使PPT对象成为全局对象并在活动演示文稿前面使用该对象使其能够工作

他们的问题是一些客观问题，正如莱马所指出的那样。下面是子程序的最终重写

Sub BuildTemplate()

'Set Global Variables
Set WB = Workbooks("tool.xlsm")             'Set this to the name of the excel file
Set Settings = WB.Sheets("SETTINGS")        'Set this to the name of the settings tab
Set Build = WB.Sheets("BUILD")              'Set this to the name of the build tab
Set Entry = WB.Sheets("ENTRY")              'Set this to the name of the entry tab

    vDPI = Settings.Cells(2, "B").Value

'Adjust column sizes
    Build.Columns(2).AutoFit
    Build.Columns(4).AutoFit
    Build.Columns(6).AutoFit
    Build.Columns(8).AutoFit

'Create Template Files
MoveFiles
'Open newly created Template File
Dim PPT As PowerPoint.Application
Set PPT = New PowerPoint.Application
    PPT.Visible = True
    PPT.Presentations.Open Filename:=vNewPrimaryTemplatePath
'Add Title Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E2")), CInt(Settings.Range("E3")), CInt(Settings.Range("E4")), CDbl(Settings.Range("E5")), CDbl(Settings.Range("E6")))

'Add Delivery Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E9")), CInt(Settings.Range("E10")), CInt(Settings.Range("E11")), CDbl(Settings.Range("E12")), CDbl(Settings.Range("E13")))

'Add Address Block
Call AddShape(False, "BUILD", CStr(Settings.Range("E16")), CInt(Settings.Range("E17")), CInt(Settings.Range("E18")), CDbl(Settings.Range("E19")), CDbl(Settings.Range("E20")))

'Add Items
Call AddShape(False, "BUILD", CStr(Settings.Range("H2")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H12")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H3")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H13")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H4")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H14")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H5")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H15")), CDbl(Settings.Range("H10")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H6")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H12")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H7")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H13")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H8")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H14")), CDbl(Settings.Range("H11")))
Call AddShape(False, "BUILD", CStr(Settings.Range("H9")), CInt(Settings.Range("H16")), CInt(Settings.Range("H17")), CDbl(Settings.Range("H15")), CDbl(Settings.Range("H11")))

'Add Summaries
    AddSummary

'Save & Close
    ActivePresentation.SaveAs Filename:=vNewPrimaryTemplatePath, FileFormat:=ppSaveAsDefault
    ActivePresentation.Close

End Sub

Private Sub AddShape(vSummary As Boolean, vSheet As String, vRange As String, Optional vFirstSlide As Integer, Optional vLastSlide As Integer, Optional vTop As Double, Optional vLeft As Variant = "Centered")
Dim Sld As Integer
Dim oSlide As Slide
Dim oShape As Object

'Copy specified cells
    WB.Sheets(vSheet).Range(vRange).Copy
'Paste to first required slide for the specified cell group
Set oSlide = PPT.ActivePresentation.Slides(vFirstSlide)
Set oShape = oSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
'Center everything before we begin
    oShape.Align msoAlignCenters, True
    oShape.Align msoAlignMiddles, True
'Set the specified top position
    oShape.Top = (vTop * vDPI)
'Determine if Left position needs set'
    If vLeft = "Centered" Then
        oShape.Align msoAlignCenters, True
    Else
        oShape.Left = (vLeft * vDPI)
    End If
'If contents is a Summary
    If vSummary Then
'While we still have it selected
        With oShape
            .LockAspectRatio = msoTrue  'Lock Aspect Ratio
            .Width = (10 * vDPI)        'Reszie to fit slide'
            .Ungroup                    'Ungroup to make it easier to edit manually'
        End With
    Else
        'Ungroup to make it easier to edit manually then copy it to paste it to all the required slides
        oShape.Ungroup.Copy
        'We pasted one already so we need to set the new first slide to the second in the series of slides to recieve the current content
        vFirstSlide = vFirstSlide + 1
        'For the specified remaineder of the slides we paste the contents we just copied.
        'NOTE: this only works if the contents are to be placed on a concurrent set of slides. this will break if the content you are adding requires random placements in the templates
        For Sld = vFirstSlide To vLastSlide
            PPT.ActivePresentation.Slides(Sld).Shapes.Paste
        Next Sld
    End If

End Sub

---

您是否尝试过粘贴分组，然后取消分组？是否可能是粘贴的上下文导致了问题-这意味着您正在复制ShapeRange对象，但尝试粘贴Shape对象。它们是绝对可替代的吗？我最初是作为一个组粘贴的，这就是错误发生的地方。至于我上面提到的Shape对象，它本身可以正常工作，ShapeRange不是幻灯片的对象，而是可选择的对象。进入调试器并使用局部变量窗口找出其中哪些不是对象：

ActivePresentation。

，

ActivePresentation.Slides（Sld）

，

ActivePresentation.Slides（Sld）.Shapes

我想其中一个不是对象，这就是问题所在。