Office更新终止了我的VBA代码以将Excel表格粘贴到现有的PowerPoint文件并幻灯片

时间：2017-11-13 23:03:31

标签： excel vba excel-vba powerpoint

在最近的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错误运行时＆＃39; -2147188160（80048240）＆＃39;：形状（未知成员）

我尝试了大多数粘贴变体，但它只允许我粘贴图片或文字。我注意到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。为什么更新会删除此功能？我已尝试使用此粘贴功能从此论坛中验证过的代码，但它不会使用以前的工作，它绝对是更新，因为我们所有的计算机现在都有同样的问题，我觉得很难也相信。

2 个答案:

答案 0 :(得分：1)

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

那些Office 365更新给我带来了一两次。但我不知道这是什么问题。

PasteSpecial上的代码失败了吗？ PasteSpecial是PowerPoint VBA的相对新手，但我认为它适用于Office 14（2010）。对PowerPoint库14.0版的引用很奇怪。你能去工具＆gt;引用并滚动到16.0版？如果是，请检查一个。您使用的是哪个版本的Office：转到“文件”标签＆gt;帐户，并找到版本号和内部版本号。

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

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

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

答案 1 :(得分：0)

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

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

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

我希望这有用。

如果您有任何建议，请与我们联系。

乔恩

相关问题
最新问题