如何解决 14 Microsoft Powerpoint 对象库和 15 Microsoft Powerpoint 之间的兼容性问题

Question

您好，这是对这张票的跟进：How to resolve Missing Powerpoint 15 Object Library Error

我开发了一个宏，可以在 Excel 2010 中将某些内容从 excel 导出到 powerpoint。当我尝试部署到使用 Office 2010 的人时遇到了问题。根据 SO 的建议，我将引用更改为后期绑定以避免版本依赖性。现在可以在 Office 2010 上打开并运行宏，但用户仍会看到错误消息：“加载 DLL 时出现问题”。当我点击参考资料时，它说缺少 15 个 Powerpoint VBA。如果我取消选中此项并选中 14，它将运行，但似乎 2010 年的某个人每次运行宏时都必须这样做。关于如何进行的任何建议？我尝试添加以下内容来解决问题

1：修复引用的代码

Sub RemoveMissingReferences()
Dim Intrefcount As Integer

With ThisWorkbook.VBProject.references
    For Intrefcount = 1 To .Count
        If Left(.Item(Intrefcount).Description, 7) = "Missing" Then
             .Remove .Item(Intrefcount)
        End If
    Next Intrefcount
   End With
End Sub

---

2：从excel导出到PPT的实际宏

Sub CopyDataToPPTBrandPers()
Const ppLayouttitleonly = 11
Const ppPasteEnhancedMetafile = 2

Dim objWorkSheet As Worksheet
Dim objRange As Range
Dim objPPT, objslide, objPresentation, shapePPTOne As Object
Dim intLocation, intHeight, inLayout, intRefCount As Integer
Dim strRange As String
Dim boolRefExists As Boolean

Application.ScreenUpdating = False

boolRefExists = False
With ThisWorkbook.VBProject.references
    For intRefCount = 1 To .Count
        If .Item(intRefCount).Description = _
            "Microsoft PowerPoint 14.0 Object Library" Then
            boolRefExists = True
        End If
    Next intRefCount
End With

Set objPPT = CreateObject("PowerPoint.Application")

objPPT.Visible = True
inLayout = 1
strRange = "p19:y48"  '<- here
intHeight = 430

Set objPresentation = objPPT.Presentations.Add
Set objslide = objPresentation.Slides.Add(1, inLayout)
objslide.Layout = ppLayouttitleonly

With objslide.Shapes.Title
    With .TextFrame.TextRange
        .Text = "Reebok - " & Sheets("Brand Personality").Cells(3, 2)
        .Words.Font.Bold = msoTrue
        .Font.Color = RGB(255, 255, 255)
    End With
    .Fill.Visible = msoTrue
    .Fill.Solid
    .Fill.ForeColor.RGB = RGB(192, 0, 0) '160, 157, 117)
    .Height = 50
End With

Set objRange = Sheets("Brand Personality").Range(strRange)
objRange.Copy

Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, _
    Link:=msoFalse)
DoEvents

If boolRefExists = True Then
    shapePPTOne.Left = 100
    shapePPTOne.Top = 100
    shapePPTOne.Height = intHeight    
Else
    shapePPTOne(1).Left = 220
    shapePPTOne(1).Top = 100
    shapePPTOne(1).Height = intHeight
End If

Set shapePPTOne = Nothing
'Set shapePPTTwo = Nothing
Set objRange = Nothing
Set objPPT = Nothing
Set objPresentation = Nothing
Set objslide = Nothing

Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Update Complete"

End Sub

Answer 1

试试这个 sn-p 来简化事情：

' PasteSpecial returns a shaperange consisting of 1 shape, so add a (1) at the end to 
' set shapePPTOne equal to the first shape in the range:
Set shapePPTOne = objslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile, _
    Link:=msoFalse)(1)
DoEvents

Then you don't need all this stuff, just shapePPTOne.Left = xxx etc.
'If boolRefExists = True Then
    shapePPTOne.Left = 100
    shapePPTOne.Top = 100
    shapePPTOne.Height = intHeight    
'Else
'    shapePPTOne(1).Left = 220
'    shapePPTOne(1).Top = 100
'    shapePPTOne(1).Height = intHeight
'End If

IIRC、msoTrue 和 msoFalse 是 Office 变量，不是特定于 PPT 的，因此您可能不需要更改它们。或者您可以简单地使用 True 和 False。

如果你已经删除了对 PPT 的引用，那么检查项目以查看引用是否存在是没有意义的；不会的。如果您留下参考，用户在未运行 2010 版 Office 时将始终看到抱怨缺少参考的消息。