Excel VBA检测Outlook是否打开，如果没有，则打开它

Question

我已经编写了将附件下载到指定文件夹的代码。

Const olFolderInbox = 6

Sub detectpp_plate_record1()

Dim oOutlook As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim unRead, m As Object, att As Object

'~~> Get Outlook instance
Set oOutlook = GetObject(, "Outlook.application")
Set oOlns = oOutlook.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)

'~~> Check if there are any actual unread emails
Set unRead = oOlInb.Items.Restrict("[UnRead] = True")

' File_Path = "D:\Attach\"

File_Path = "C:\Users\Desktop\pocket setter excel\"

If unRead.Count = 0 Then
    MsgBox "NO Unread Email In Inbox"
Else
    For Each m In unRead
        If m.Attachments.Count > 0 Then
            For Each att In m.Attachments
                If att.Filename Like "plate record*" Then
                    MsgBox "Unread Email with attachment available In Inbox"
                   
                    'Like "plate record*.xls"
                    '~~> Download the attachment
                    ' to the file path and file name
                    'att.Filename = name of attachement
                        
                    att.SaveAsFile File_Path & "plate record"
                            
                    'att.SaveAsFile File_Path & att.Filename
                            
                    '& Format(plate record)
                            
                    ' mark attachment as read               
                    m.unRead = False
                    DoEvents
                    m.Save
               
                    WorkFile = Dir(File_Path & "*")

                    Do While WorkFile <> ""

                       If Right(WorkFile, 4) <> "xlsm" Then
                          Workbooks.Open Filename:=File_Path & WorkFile
                          ActiveWorkbook.SaveAs Filename:= _
                            File_Path & WorkFile & "", FileFormat:= _
                            xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
                          ActiveWorkbook.Close
                          Kill File_Path & WorkFile
                        End If

                        WorkFile = Dir()
                    Loop

                    Exit Sub
                End If
            Next att
        End If
    Next m
End If
End Sub

问题：只有在打开 Outlook 时才能执行。

所以我要单独打开Outlook

我的要求是用ExcelVBA代码检测Outlook是否打开，如果没有，则应该打开

--------------------更新-------------------- -----

我把上面的代码和下面的代码结合起来了。

#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderInbox As Long = 6

Sub detectpp_plate_record()
    MyMacroThatUseOutlook
    detectpp_plate_record1
End Sub

#If LateBind Then

Public Function OutlookApp( _
    Optional WindowState As Long = olMinimized, _
    Optional ReleaseIt As Boolean = False _
    ) As Object
    Static oOutlook As Object
#Else
Public Function OutlookApp( _
    Optional WindowState As Outlook.OlWindowState = olMinimized, _
    Optional ReleaseIt As Boolean _
) As Outlook.Application
    Static oOutlook As Outlook.Application
#End If
On Error GoTo ErrHandler
 
    Select Case True
        Case oOutlook Is Nothing, Len(oOutlook.name) = 0
            Set oOutlook = GetObject(, "Outlook.Application")
            If oOutlook.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                oOutlook.Session.GetDefaultFolder(olFolderInbox).Display
                oOutlook.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set oOutlook = Nothing
    End Select
    Set OutlookApp = oOutlook
 
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set oOutlook = Nothing
        Case 429, 462
            Set oOutlook = GetOutlookApp()
            If oOutlook Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
    
    Set GetOutlookApp = CreateObject("Outlook.Application")
    
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub MyMacroThatUseOutlook()
    Dim OutApp  As Object
    Set OutApp = OutlookApp()
    'Automate OutApp as desired
End Sub

现在，如果 Outlook 已打开，代码会搜索指定的未读电子邮件。

如果 Outlook 已关闭，它会打开它，但之后出现错误

运行时间错误429:

ActiveX 组件无法创建对象。

因此，我必须再次单击按钮以获取用于搜索指定电子邮件的代码。

如何消除此错误并一次性执行此操作？

Answer 1

像这样：-

Set oOutlook = GetObject(, "Outlook.application")
If oOutlook is nothing Then
  'outlook is not running so start it
  set oOutlook = New Outlook.Application
Else
' outlook is running
End If

Answer 2

将此添加到您的代码中：

Dim oOutlook As object

    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")
    On Error Goto 0 

    If oOutlook Is Nothing Then
        Set oOutlook = CreateObject("Outlook.Application")
    End If

我试过并测试过。有效。

Excel VBA检测Outlook是否打开，如果没有，则打开它

Excel VBA to detect if Outlook is open, if its not ,then open it

excel

outlook

vba