Excel VBA Emails, occasional errors occuring - vba

Question

The code throws an occasional Run-time error '424': Object required.
The spreadsheet contains a person's first name in column "C", email addresses in "BG" column; Outlook emails are generated when an error value in "AO" column is >=3 AND if there is an empty cell in "AU" column. For the loop to close, a date stamp is inserted into the "AU" column.
The code is at the Sheet level. This generic sheet is supposed to serve as a template for month's worth of data; i.e. copied 12 times/year into the same workbook.
Any advice on how to eliminate the error messages? Thank you in advance.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'This code cycles through each row and looks for an email address in "BG" column.
'If found and recipient "C"'s 'Total Error Occurences' "AO" value is >=3, an email is generated for a display.
'To close the loop on each row, a date is entered into 'Date Email Generated' "AU".
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("BG").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
Cells(cell.Row, "AO").Value >= 3 And _
IsEmpty(Cells(cell.Row, "AU").Value) = True Then _
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Test E-mail"
.Body = "Dear " & Cells(cell.Row, "C").Value _
& vbNewLine & vbNewLine & _
"This is a " & vbNewLine & _
"test email." & vbNewLine & _
vbNewLine & vbNewLine & _
"Signature"
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
With Cells(cell.Row, "AU")
.Value = Date
.NumberFormat = "mm/dd/yy"
End With
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

Answer 1

Try using existing instance, or else creating a new instance if one is not already running,
Dim MyApp As Boolean
Dim OutApp As Object
Dim OutMail As Object
'// Open or Start a new instance of Outlook
On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
MyApp = True
Set OutApp = CreateObject("Outlook.Application")
End If
'// then Create an Outlook Mail Item
Or see nice Function StartOutlook example from Daniel Pineault Click here
Function StartOutlook()
On Error GoTo Error_Handler
Dim oOutlook As Object
Dim sAPPPath As String
If IsAppRunning("Outlook.Application") = True Then 'Outlook was already running
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
Else 'Could not get instance of Outlook, so create a new one
sAPPPath = GetAppExePath("outlook.exe") 'determine outlook's installation path
Shell (sAPPPath) 'start outlook
Do While Not IsAppRunning("Outlook.Application")
DoEvents
Loop
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
End If
' MsgBox "Outlook Should be running now, let's do something"
Const olMailItem = 0
Dim oOutlookMsg As Object
Set oOutlookMsg = oOutlook.CreateItem(olMailItem) 'Start a new e-mail message
oOutlookMsg.Display 'Show the message to the user
Error_Handler_Exit:
On Error Resume Next
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: StartOutlook" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
End Function