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。

我的要求是使用Excel VBA代码来检测Outlook是否已打开，如果不是，则应该打开它。

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

我将上面的代码与以下代码结合起来。

#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

将此添加到您的代码中：

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

我试过并测试过它。它有效。

Answer 2

这样的事情： -

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

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

2 个答案: