Office更新扼杀了我将Excel表粘贴到现有PowerPoint文件和幻灯片的VBA代码

Question

在最近的Office 365更新后，我将表从Excel复制到Power Point的代码停止工作。

上一个代码：

Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pSlide As PowerPoint.Slide
Dim objPPT As Object
Dim myRange As Excel.Range
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
FilePath = "\Model"
Filename = "Template Monthly reports.pptx"
file = FilePath & Filename
Set pptPrez = objPPT.Presentations.Open(file)
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With osh
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With

代码继续粘贴表格和图片。然后

End if
End sub

我得到以下错误：

VBA错误运行时"-2147188160(80048240)"：形状(未知成员)

我尝试过大多数粘贴变体，但它只允许我粘贴图片或文本。我注意到VBA参考库的修订版似乎已经减少到Microsoft PowerPoint 14.0对象库，而我确信它是在15或16之前构建的。这会是原因吗？

我想出了一个解决方案，那就是使用

'Slide 1 title 1
i = 1
Set pSlide = pptPrez.Slides(i)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
pptPrez.Windows(1).Activate
pptPrez.Windows(1).View.GotoSlide i
pptPrez.Slides(i).Shapes("Title").Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
With pptPrez.Slides(i)
With .Shapes("Title")
.LockAspectRatio = msoFalse
.Top = 160
.Left = 135
.Height = 70
.Width = 550
'.TextFrame.TextRange.Font.Name = "Futura Bold"
'.TextFrame.TextRange.Font.Size = 24
'.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
'.TextFrame.TextRange.ParagraphFormat.WordWrap = msoTrue
End With
End With

作为替代方案，我必须手动创建所有表，然后命名它们，并在有效的代码中选择它们，但要求窗口处于活动状态似乎不那么一致和可靠，这更容易出错。

有什么想法可以让第一个代码重新工作吗？我仍然可以手动粘贴，但似乎没有使用pastespecial。为什么更新会删除此功能？我已经尝试过使用这个粘贴功能从这个论坛验证过的代码，但它以前也不起作用，这肯定是更新，因为我们所有的计算机现在都有同样的问题，我也很难相信。

Answer 1

我决定写一个答案，而不是一堆注释，因为我想发布我的代码。

那些Office 365更新已经吸引了我两三次。但我不知道问题出在哪里。

PasteSpecial上的代码失败了？PasteSpecial是PowerPoint VBA的新手，但我认为它适用于Office 14(2010)。对PowerPoint库14.0版本的引用很奇怪。你能转到"工具">"参考资料"并滚动到16.0版本吗？如果是，请检查那个。您使用的Office版本：转到"文件"选项卡>"帐户"，然后找到版本号和内部版本号。

为什么同时具有CreateObject和GetObject。对于PowerPoint，您只需要使用CreateObject执行一次。如果PowerPoint正在运行，CreateObject将返回正在运行的实例；如果没有，则返回一个新实例。可能不重要，但它会增加混乱。将CreateObject移动到GetObject所在的位置，并将objPPT更改为pptApp(因为您不需要两者)。

此外，您还使用了三个未声明的变量。将MonthNo和MonthData声明为Variant，将osh声明为PowerPoint.Shape(实际上，在我的代码中，为了保持一致性，我将其重命名为pptShape和pSlide)。

通过额外的修改，使用活动演示文稿，而不是在给定的路径和文件名打开一个演示文稿，你的代码对我来说很好。我正在运行1711版本，构建8711.2037，这是值得的。

这是对我来说运行良好的代码。

Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim myRange As Excel.Range
Dim pptShape As PowerPoint.Shape
Dim MonthNo As Variant
Dim MonthData As Variant
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'' JP - use active presentation instead of opening one
''FilePath = "\Model"
''Filename = "Template Monthly reports.pptx"
''file = FilePath & Filename
''Set pptPrez = objPPT.Presentations.Open(file)
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pptSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" _
& Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set pptShape = pptSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With pptShape
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With
End If
End Sub

Answer 2

我已经更新了替代解决方案，它可能会帮助其他人，因为它做了一些事情；将表格复制到现有演示文稿和幻灯片，更新旧形状和新形状，将图片复制到带有弹出框的新幻灯片，以便在粘贴表格时进行选择。

我做了一个函数来减少主代码，使其更容易管理，因为我有几十个副本和粘贴。我还没有粘贴所有内容，但展示了一些不同的粘贴方式：

Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private pptApp As PowerPoint.Application
Private pptPres As PowerPoint.Presentation
Private pSlide As PowerPoint.Slide
Private TTop, TLeft As Variant
Private TableCount, SlideNo As Integer
Private MyRange As Excel.Range
Private ShapeName As String
Private Function CreateTable()
Dim l As Long
Set pSlide = pptPres.Slides(SlideNo)
MyRange.Copy
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide SlideNo
With pptPres.Slides(SlideNo)
If ShapeName = isblank Then
Else
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
End If
For l = 1 To 100
DoEvents
Next l
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
For l = 1 To 500
DoEvents
Next l
pptApp.CommandBars.ReleaseFocus
NoShapes = pSlide.Shapes.Count
If ShapeName = isblank Then
pptPres.Slides(SlideNo).Shapes(NoShapes).Name = "Table" & TableCount
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
With .Shapes("Table" & TableCount)
.LockAspectRatio = msoFalse
If TTop = isblank Then
Else
.Top = TTop
End If
If TLeft = isblank Then
Else
.Left = TLeft
End If
End With
TableCount = TableCount + 1
Else
End If
End With
ShapeName = ""
TLeft = ""
TTop = ""
Application.CutCopyMode = False
End Function
Sub GeneratePresentation()
Dim FilePath, Filename, file As String
Dim MonthNo, MonthData As Variant
Dim x, y As Variant
Dim UpdateRecords As Integer
Dim WB As Excel.Workbook
FilePath = "\Model"
Filename = "Template Weekly Report.pptx"
file = FilePath & Filename
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(file) ' using a specific presentation or template
Set pptPres = pptApp.ActivePresentation
TableCount = 1
'Slide 1 title 1
SlideNo = 1
Sheets("01").Range("D3") = "= ""Weekly Report """
Sheets("01").Range("D4") = "= ""For Week No. ""&TEXT(WEEKNUM(NOW(),16),""#"")& "" - internal"""
Set MyRange = Sheets("0" & SlideNo).Range("D3:D4")
TTop = 160
TLeft = 135
Call CreateTable
'Slide 1 title 2
Sheets("01").Range("D7").Formula = "=DAY(Entry!B4)&LOOKUP(DAY(Entry!B4),{1,2,3,4,21,22,23,24,31;""st"",""nd"",""rd"",""th"",""st"",""nd"",""rd"",""th"",""st""})&TEXT(Entry!B4,"" mmmm yyy"")"
Set MyRange = Sheets("0" & SlideNo).Range("D7")
TTop = 280
TLeft = 135
Call CreateTable
'slide 2 table 1
SlideNo = 2
Set MyRange = Sheets("0" & SlideNo).Range("B33:T40")
TTop = 380
Call CreateTable
'Slide 2 chart 1
ActiveWorkbook.Sheets("0" & SlideNo).ChartObjects("Chart 1").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)(1)
With osh
.Top = 98
.Left = 35
.Width = 430
End With
'Slide 3 table 1
SlideNo = 3
Set pSlide = pptPres.Slides(SlideNo)
UpdateRecords = MsgBox("Update Records", vbYesNo, "Update Records?")
If UpdateRecord = yes Then
Set MyRange = Sheets("0" & SlideNo).Range("E17:I20")
TTop = 330
Call CreateTable
Else
End If
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide 1
End Sub

我希望这会有所帮助。

如果你有什么建议，请告诉我。

Jon