vba - Office 更新杀死了我的 VBA 代码，无法将 Excel 表格粘贴到现有的 PowerPoint 文件和幻灯片中

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 error Run-time '-2147188160 (80048240)': Shapes (unknown member)

我已经尝试过大多数粘贴变体，但它只能让我粘贴图片或文本。我注意到 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:转到"file"选项卡 >“帐户”，然后找到版本号和内部版本号。

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

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

通过使用事件演示文稿而不是在给定路径和文件名打开一个演示文稿的额外修改，您的代码对我来说很好。我正在运行版本 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