CreateObject(“Outlook.Application”)不工作，为什么？

时　间:2014-11-18 09:06:28
作　者:金宇转载   ID：43  城市：江阴
摘　要:启动outlook的解决方案
正　文:

由于大多数开发人员都知道，自动化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

下面是我解决这个问题的方案

  

'---------------------------------------------------------------------------------------

' 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


Access软件网QQ交流群 (群号:54525238) 　　　　　　Access源码网店