由于大多数开发人员都知道，自动化MS Office应用程序时，您可以通过绑定到现有实例，或创建一个新的实例来运行。因此，你会经常使用这样的代码：
Dim oExcel As Object
On Error Resume Next
Set oExcel = GetObject(, "Excel.Application") 'Bind to existing instance of Excel
If Err.Number <> 0 Then 'Could not get instance of Excel, so create a new one
Err.Clear
On Error GoTo Error_Handler
Set oExcel = CreateObject("excel.application")
End If
On Error GoTo Error_Handler
|
对于Excel，Word，PowerPoint这种方试很好。但是，如果你想自动化Outlook，你会很快意识到，这种方法行不通！
下面是我解决这个问题的方案
'---------------------------------------------------------------------------------------
' Procedure : StartOutlook
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Demonstration of how one can start outlook if it isn't already started
' considering CreateObject("Outlook.Application") not longer works!
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Usage:
' ~~~~~~
'
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' *********************************************************
' 1 2014-Oct-31 Initial Release
'---------------------------------------------------------------------------------------
Function StartOutlook()
On Error GoTo Error_Handler
Dim oOutlook As Object
Dim sAPPPath As String
If IsAppRunning("Outlook.Application") = True Then 'Outlook was already running
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Else 'Could not get instance of Outlook, so create a new one
sAPPPath = GetAppExePath("outlook.exe") 'determine outlook's installation path
Shell (sAPPPath) 'start outlook
Do While Not IsAppRunning("Outlook.Application")
DoEvents
Loop
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
End If
' MsgBox "Outlook Should be running now, let's do something"
Const olMailItem = 0
Dim oOutlookMsg As Object
Set oOutlookMsg = oOutlook.CreateItem(olMailItem) 'Start a new e-mail message
oOutlookMsg.Display 'Show the message to the user
Error_Handler_Exit:
On Error Resume Next
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: StartOutlook" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function
'---------------------------------------------------------------------------------------
' Procedure : IsAppRunning
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Determine is an App is running or not
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sApp : GetObject Application to verify if it is running or not
'
' Usage:
' ~~~~~~
' IsAppRunning("Outlook.Application")
' IsAppRunning("Excel.Application")
' IsAppRunning("Word.Application")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' *********************************************************
' 1 2014-Oct-31 Initial Release
'---------------------------------------------------------------------------------------
Function IsAppRunning(sApp As String) As Boolean
On Error GoTo Error_Handler
Dim oApp As Object
Set oApp = GetObject(, sApp)
IsAppRunning = True
Error_Handler_Exit:
On Error Resume Next
Set oApp = Nothing
Exit Function
Error_Handler:
Resume Error_Handler_Exit
End Function
'---------------------------------------------------------------------------------------
' Procedure : GetAppExePath
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Determine the path for a given exe installed on the local computer
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
'
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sEXEName : Name of the exe to locate
'
' Usage:
' ~~~~~~
' Call GetAppExePath("msaccess.exe")
' GetAppExePath("firefox.exe")
' GetAppExePath("outlook.exe")
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' ***************************************
******************
' 1 2014-Oct-31 Initial Release
'---------------------------------------------------------------------------------------
Function GetAppExePath(ByVal sExeName As String) As String
On Error GoTo Error_Handler
Dim WSHShell As Object
Set WSHShell = CreateObject("Wscript.Shell")
GetAppExePath = WSHShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\" & sExeName & "\")
Error_Handler_Exit:
On Error Resume Next
Set WSHShell = Nothing
Exit Function
Error_Handler:
If Err.Number = -2147024894 Then
'Cannot locate requested exe????
Else
MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: " & sModName & "/GetAppExePath" & vbCrLf & _
"Error Description: " & Err.Description, _
vbCritical, "An Error has Occured!"
End If
Resume Error_Handler_Exit
End Function
