I am working on a macro that builds a briefing template based on data entered into excel
Error I am receiving: ActiveX component can't create object or return reference to this object (Error 429)
Since their are various objets that need to be created on several slides i wrote a subroutine that can be reused for each object based on some settings set within the excel file
This is the subroutine that runs
Its erring out on the paste function itself, hovering over the variables within that line gives me the correct values required. I have tested it on its own and it works fine with the values its receiving. I also check to ensure that the values were copied from excel and they were.
I am kin dof at a loss on this one.
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
I am calling from the following subroutine
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
I managed to figure it all out and get it working fine.
It was a scope issue the ActivePresentation inside the subprocedue did not have access to the powerpoint application. Making the PPT object global and using that infront of the Active presentation enabled it to work.
Their were some object issues as well as ElectricLlama has pointed out. here is the final rewrite of the subroutine
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.