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

Question

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:\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
The problem : This can be executed only when Outlook is open.
Therefore I have to separately open Outlook.
My requirement is to use Excel VBA code to detect if Outlook is open, if it is not, then it should be opened.
---------------------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
Now, if Outlook is open the code searches for the specified unread email.
If Outlook is closed, it opens it, but afterwards there is an error
Run time error 429:
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?

Answer 1

Add this to your code:
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
I tried and tested it . It works.

Answer 2

Something like this:-
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