VBA - 检测是否安装了应用程序以使用它
VBA - Detect if an application is installed to use it
我制作了一个 Excel 文件,其中存储了很多自定义工业零件的信息。
它允许用户通过 Outlook 发送预先格式化的邮件以询问新价格。
不幸的是,有些用户的 "light" 桌面没有 Outlook,他们收到错误消息:
Can't find Project or Library
不幸的是,安装 Outlook 不是一个选项,延迟投标已经完成。
我在考虑 预处理器指令,但我不知道如何在我的案例中使用它们...
我知道可以用于 Windows 和 VBA 版本的常量:see here
我会做这样的事情:
#If Outlook then
MsgBox "Outlook is installed"
#Else
MsgBox "Outlook is NOT installed"
#End if
但这只会检测代码是否来自 Outlook 运行,这不是我需要的...:/
所以我想我可以用 On Error
做一些事情,但它看起来不太好,有什么建议吗?
你可以这样做:
Sub Whatever()
Dim obj As Object
Set obj = CreateObjectType("Outlook.Application")
If Not obj Is Nothing Then
'...
End If
End Sub
Public Function CreateObjectType(objectType As Variant) As Object
On Error Resume Next
CreateObjectType = CreateObject(objectType)
End Function
你可以尝试类似的东西...
Dim olApp As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not installed on your system." & vbNewLine & vbNewLine & _
"Please Install & Configure The Outlook And Then Try Again...", vbExclamation, "Outlook Not Installed!"
Exit Sub
End If
这是我的解决方案:
Option Explicit
Sub TestMe()
Debug.Print blnObjectInstalled
End Sub
Public Function blnObjectInstalled(Optional strObjectType As String = "Outlook.Application") As Boolean
On Error GoTo blnobjectInstalled_Error
Dim obj As Object
Set obj = CreateObject(strObjectType)
blnObjectInstalled = True
On Error GoTo 0
Exit Function
blnobjectInstalled_Error:
blnObjectInstalled = False
End Function
我们的想法是我们做一个布尔函数,定义对象是否被安装,接受一个可选的字符串,这样它就可以检查各种对象。作为字符串值,更容易检查。
使用预处理器指令执行此操作似乎是不可能的,因为您需要设置一个等于检查是否安装了 Outlook 的函数的常量,而常量不喜欢这种方式。
我试图找到不依赖 CreateObject 错误的其他检测应用程序的方法
这使用了 WMI 对象,它似乎运行良好,但它不能区分演示版本
它在注册表路径 Microsoft\Windows\CurrentVersion\App Paths
(32 位和 64 位)
中列出已安装的应用程序
Public Function AppDetected() As Boolean
Const HKEY_LOCAL_MACHINE = &H80000002 'HKEY_CURRENT_USER = &H80000001
Const APP_PATH = "\Microsoft\Windows\CurrentVersion\App Paths\"
Const APP_PATH_32 = "SOFTWARE" & APP_PATH
Const APP_PATH_64 = "SOFTWARE\Wow6432Node" & APP_PATH
Const REG_ITM = "!\.\root\default:StdRegProv"
Const REG = "winmgmts:{impersonationLevel=impersonate}" & REG_ITM
Const ID = "Outlook" '"OUTLOOK.EXE"
Dim wmi As Object, subKeys As Variant, found As Variant
If wmi Is Nothing Then Set wmi = GetObject(REG)
If wmi.EnumKey(HKEY_LOCAL_MACHINE, APP_PATH_32, subKeys) = 0 Then
If Not IsNull(subKeys) Then found = UBound(Split(Join(subKeys), ID)) > 0
End If
If Not found Then
If wmi.EnumKey(HKEY_LOCAL_MACHINE, APP_PATH_64, subKeys) = 0 Then
If Not IsNull(subKeys) Then found = UBound(Split(Join(subKeys), ID)) > 0
End If
End If
AppDetected = found
End Function
注意:我只在没有 Outlook 的机器上测试过
来自 MS
的有关 WMI Tasks: Registry 的更多详细信息
另一个使用 MIME 的 WMI 版本,显示已安装的 MS 应用程序,在 VBScript 中:
Set wmi = GetObject("winmgmts:\.\root\CIMV2")
Set itms = wmi.ExecQuery("SELECT * FROM Win32_MIMEInfoAction", "WQL", &h10 + &h20)
For Each itm In itms
WScript.Echo itm.Name
Next
检测 MS Mail,类似于 CreateObject:Application.ActivateMicrosoftApp xlMicrosoftMail
确定 Outlook 用户帐户:
'If Outlook exists, set reference to Microsoft Outlook *
Public Function ShowOutlookAccount() As Long
Dim appOutlook As Outlook.Application, i As Long
Set appOutlook = CreateObject("Outlook.Application")
For i = 1 To appOutlook.Session.Accounts.Count
Debug.Print appOutlook.Session.Accounts.Item(i) & " : Account number " & i
Next
End Function
更多 Outlook utils 来自 Ron de Bruin
我制作了一个 Excel 文件,其中存储了很多自定义工业零件的信息。
它允许用户通过 Outlook 发送预先格式化的邮件以询问新价格。
不幸的是,有些用户的 "light" 桌面没有 Outlook,他们收到错误消息:
Can't find Project or Library
不幸的是,安装 Outlook 不是一个选项,延迟投标已经完成。
我在考虑 预处理器指令,但我不知道如何在我的案例中使用它们...
我知道可以用于 Windows 和 VBA 版本的常量:see here
我会做这样的事情:
#If Outlook then
MsgBox "Outlook is installed"
#Else
MsgBox "Outlook is NOT installed"
#End if
但这只会检测代码是否来自 Outlook 运行,这不是我需要的...:/
所以我想我可以用 On Error
做一些事情,但它看起来不太好,有什么建议吗?
你可以这样做:
Sub Whatever()
Dim obj As Object
Set obj = CreateObjectType("Outlook.Application")
If Not obj Is Nothing Then
'...
End If
End Sub
Public Function CreateObjectType(objectType As Variant) As Object
On Error Resume Next
CreateObjectType = CreateObject(objectType)
End Function
你可以尝试类似的东西...
Dim olApp As Object
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not installed on your system." & vbNewLine & vbNewLine & _
"Please Install & Configure The Outlook And Then Try Again...", vbExclamation, "Outlook Not Installed!"
Exit Sub
End If
这是我的解决方案:
Option Explicit
Sub TestMe()
Debug.Print blnObjectInstalled
End Sub
Public Function blnObjectInstalled(Optional strObjectType As String = "Outlook.Application") As Boolean
On Error GoTo blnobjectInstalled_Error
Dim obj As Object
Set obj = CreateObject(strObjectType)
blnObjectInstalled = True
On Error GoTo 0
Exit Function
blnobjectInstalled_Error:
blnObjectInstalled = False
End Function
我们的想法是我们做一个布尔函数,定义对象是否被安装,接受一个可选的字符串,这样它就可以检查各种对象。作为字符串值,更容易检查。
使用预处理器指令执行此操作似乎是不可能的,因为您需要设置一个等于检查是否安装了 Outlook 的函数的常量,而常量不喜欢这种方式。
我试图找到不依赖 CreateObject 错误的其他检测应用程序的方法
这使用了 WMI 对象,它似乎运行良好,但它不能区分演示版本
它在注册表路径 Microsoft\Windows\CurrentVersion\App Paths
(32 位和 64 位)
Public Function AppDetected() As Boolean
Const HKEY_LOCAL_MACHINE = &H80000002 'HKEY_CURRENT_USER = &H80000001
Const APP_PATH = "\Microsoft\Windows\CurrentVersion\App Paths\"
Const APP_PATH_32 = "SOFTWARE" & APP_PATH
Const APP_PATH_64 = "SOFTWARE\Wow6432Node" & APP_PATH
Const REG_ITM = "!\.\root\default:StdRegProv"
Const REG = "winmgmts:{impersonationLevel=impersonate}" & REG_ITM
Const ID = "Outlook" '"OUTLOOK.EXE"
Dim wmi As Object, subKeys As Variant, found As Variant
If wmi Is Nothing Then Set wmi = GetObject(REG)
If wmi.EnumKey(HKEY_LOCAL_MACHINE, APP_PATH_32, subKeys) = 0 Then
If Not IsNull(subKeys) Then found = UBound(Split(Join(subKeys), ID)) > 0
End If
If Not found Then
If wmi.EnumKey(HKEY_LOCAL_MACHINE, APP_PATH_64, subKeys) = 0 Then
If Not IsNull(subKeys) Then found = UBound(Split(Join(subKeys), ID)) > 0
End If
End If
AppDetected = found
End Function
注意:我只在没有 Outlook 的机器上测试过
来自 MS
的有关 WMI Tasks: Registry 的更多详细信息另一个使用 MIME 的 WMI 版本,显示已安装的 MS 应用程序,在 VBScript 中:
Set wmi = GetObject("winmgmts:\.\root\CIMV2")
Set itms = wmi.ExecQuery("SELECT * FROM Win32_MIMEInfoAction", "WQL", &h10 + &h20)
For Each itm In itms
WScript.Echo itm.Name
Next
检测 MS Mail,类似于 CreateObject:Application.ActivateMicrosoftApp xlMicrosoftMail
确定 Outlook 用户帐户:
'If Outlook exists, set reference to Microsoft Outlook *
Public Function ShowOutlookAccount() As Long
Dim appOutlook As Outlook.Application, i As Long
Set appOutlook = CreateObject("Outlook.Application")
For i = 1 To appOutlook.Session.Accounts.Count
Debug.Print appOutlook.Session.Accounts.Item(i) & " : Account number " & i
Next
End Function
更多 Outlook utils 来自 Ron de Bruin