简介：我有一个VBA应用程序，大约有5000行，可以在Excel中处理数据，构建自动图表，然后将图表从每个工作表导出到不同的PowerPoint幻灯片。在过去的5个月中，这在许多运行此代码的计算机上都可以正常工作。
问题：我组织中的某些PC已从Office 2010升级到Office 2013和Office2016。在我的代码中，我正在PowerPoint处理上使用Early Binding，这导致错误，因为VB项目的引用已从“ Microsoft PowerPoint 14.0对象库”到“ Microsoft PowerPoint 15.0对象库”。
目标：如何根据运行我的代码的PC的PowerPoint版本，通过代码自动更改引用？
状态：我当前的代码能够遍历所有已启用的VBProject引用，检查其中是否有“缺少”的内容，并删除它们以避免出现错误消息。我还可以通过代码添加PowerPoint 14.0库。
我的问题：当PowerPoint不运行时，如何根据运行此代码的当前用户的PC上运行的PowerPoint添加PowerPoint库？不运行PC时，如何阅读安装在PC上的PowerPoint版本？
另外，如果您在不同的Windows版本上运行PC，“ Microsoft PowerPoint 15.0对象库”和“ Microsoft PowerPoint 16.0对象库”以及其他版本的文件夹位置是否会更改？像Win7 32位不同于Win10 32位？并不同于Win10 64-但是？
“奖金”问题：我无法在网上任何地方找到图表（或列表）来存储“ MSPPT.OLB”文件的文件夹位置，不同的操作系统和不同的Office版本的所有数据。
Option Explicit
Sub RemoveMissingReferences_AddReference()
' display Windows Version installed on this PC
' Win7. (=6.1, 64bit)
' Win8 (=6.2, 64bit)
' Win8.1 (=6.3*)
' Win10 (=10.0*)
'
MsgBox "Windows Version is: " & getVersion
MsgBox "Excel Version is: " & Application.Version
Dim theRef As Variant, i As Long
Dim ProjRef() As String
ReDim ProjRef(1 To ThisWorkbook.VBProject.References.count)
'Remove any missing references
For i = ThisWorkbook.VBProject.References.count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
ProjRef(i) = theRef.FullPath ' read path to string array , will use it later
' if reference is "Missing" >> remove it to avoid error message
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
' add a Reference to PowerPoint , according to version running on the PC
Dim NewRef_FullPath As String
NewRef_FullPath = "C:\Program Files (x86)\Microsoft Office\Office14\MSPPT.OLB" ' Add PowerPoint 2010 Windows 7-32Bit
' loop through all existing references and check if new requested reference already checked
For i = 1 To UBound(ProjRef)
If InStr(1, ProjRef(i), NewRef_FullPath) > 0 Then ' reference already installed on PC >> pevious code runs
MsgBox "New Ref already installed"
Exit Sub
End If
Next i
On Error GoTo CanNotAddPowerPoint
Application.VBE.ActiveVBProject.References.AddFromFile NewRef_FullPath 'try to add a reference to PowerPoint
MsgBox "New Ref successfully installed"
Exit Sub
CanNotAddPowerPoint:
MsgBox "Can not reference PowerPoint"
End Sub
在我看来，您可以使用Windows Installer对象来执行此操作-它使您几乎可以访问在MSI安装程序中注册的所有内容的信息。
第一步是找到Office安装信息。不幸的是，这是String基于的，因此您需要过滤输出。我使用了一个简单的Like比较，以匹配Office版本（专业版，家庭版等）。那是唯一可能需要调整的东西。请注意，尽管您可以尽早绑定到Microsoft Windows Installer对象库，但是除了初始开发以外，它对于其他任何事情都是毫无意义的-您不能使用WindowsInstaller.Installerwith创建一个Set whatever = New WindowsInstaller.Installer。您必须使用CreateObject。
Private Function FindPowerPointPath() As String
With CreateObject("WindowsInstaller.Installer")
Dim prod As Variant
For Each prod In .Products
Dim id As String
id = .ProductInfo(prod, "ProductName")
If id Like "Microsoft Office * ####" Then
Dim location As String
location = FindPowerPointLibrary(.ProductInfo(prod, "InstallLocation"))
If location <> vbNullString Then
FindPowerPointPath = location
Exit Function
End If
End If
Next
End With
End Function
第二步非常简单-只需递归安装目录的子目录，直到找到MSPPT.OLB：
Private Function FindPowerPointLibrary(startPath As String) As String
With New Scripting.FileSystemObject
Dim cwd As Scripting.Folder
Set cwd = .GetFolder(startPath)
Dim test As String
test = .BuildPath(startPath, "MSPPT.OLB")
If .FileExists(test) Then
FindPowerPointLibrary = test
Exit Function
End If
Dim subdir As Scripting.Folder
For Each subdir In cwd.SubFolders
Dim found As String
found = FindPowerPointLibrary(subdir.Path)
If found <> vbNullString Then
FindPowerPointLibrary = found
Exit Function
End If
Next
End With
End Function
这适用于任何Windows版本（XP或更高版本？）。请注意，这当前仅返回找到的第一个实例。如果你担心多个Office版本安装的可能性，你应该能够正好验证返回路径包含Office##其中##的主要版本匹配Application.Version。
本文收集自互联网，转载请注明来源。
如有侵权，请联系[email protected] 删除。
我来说两句