Excel VBA以检测Outlook是否打开，如果没有打开，则将其打开

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

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

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 -----------------------

我将上面的代码与下面的代码结合在一起。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

#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组件无法创建对象。

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

如何摆脱此错误并一次性执行？