Excel VBA 检测 Outlook 是否打开，如果未打开，则打开它 [英] Excel VBA to detect if Outlook is open, if its not ,then open it

问题描述

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

I have written code to download an attachment to a specified folder.

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:UsersDesktoppocket 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.

我的需求是使用Excel VBA代码检测Outlook是否打开，如果没有，则应该打开.

---------------------UDATE-----------------------

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

I combined the above code with the following code.

#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 处于打开状态，代码将搜索指定的未读电子邮件.

Now, if Outlook is open the code searches for the specified unread email.

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

If Outlook is closed, it opens it, but afterwards there is an error

运行时错误 429:

ActiveX 组件无法创建对象.

ActiveX component cant create object.

因此我必须再次点击代码按钮来搜索指定的电子邮件.

Therefore once again I have to click on button for the code to search for the specified emails.

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

How do I get rid of this error and perform this in one go?

推荐答案

将此添加到您的代码中:

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 是否打开，如果未打开，则打开它的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！