[英]When pasting into powerPoint from Excel using vba, only PasteMetafilePicture works
[英]ActiveX Error when pasting from excel to powerpoint via vba
我正在使用一個宏,該宏根據輸入到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
我設法弄清楚了一切,並使它工作正常。
這是一個范圍問題,子過程中的ActivePresentation無法訪問Powerpoint應用程序。 將PPT對象設置為全局對象並使用Active演示文稿的該內部功能可以使其正常工作。
正如ElectricLlama指出的那樣,它們是一些對象問題。 這是子程序的最終重寫
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.