Problem trying to create mailitem from Access if Outlook wasn't running

[Richard Sherratt]

I have some code to create and display/send mail items from Access
that I've been using for years. Now the users want to know if the mail
item has actually been sent.

I created a class module, used "WithEvents" and modified my code as
appropriate (I think). And it works when Outlook is already open. But,
if Outlook isn't running, I get a "The operation failed." error when
trying to CreateItem(olMailItem).

Relevant code follows.

In the class module "clsEmailLinked":

Public objOutlook As outlook.Application
Public WithEvents objNewMailLinked As outlook.MailItem
Public nsOutl As outlook.Namespace
Public objRecipient As outlook.Recipient

Private fOutlWasRunning As Boolean
Private fMailSent As Boolean

Private Function GetCreateOutlookObject(fWasRunning As Boolean) As
Boolean

Dim strProcName As String
strProcName = "basAutomation.GetCreateOutlookObject"

On Error GoTo GetCreateOutlookObjectErr

GetCreateOutlookObject = True

' Resume to the next line following the error.
On Error Resume Next
' Attempt to reference Outlook which is already running.
Set objOutlook = GetObject(, "Outlook.Application")

' If true, Outlook is not running.
If objOutlook Is Nothing Then
fWasRunning = False
' Create a new instance of the Outlook application.
Set objOutlook = New outlook.Application
' If true, MS Outlook is not installed.
If objOutlook Is Nothing Then
MsgBox "MS Outlook is not installed on your computer"
GetCreateOutlookObject = False
Else
Set nsOutl = objOutlook.GetNamespace("MAPI")
If nsOutl Is Nothing Then
MsgBox "Couldn't ceate Outlook Namespace", vbCritical
GetCreateOutlookObject = False
End If
End If
Else
fWasRunning = True
End If

GetCreateOutlookObjectExit:

On Error Resume Next
Exit Function

GetCreateOutlookObjectErr:

Call FatalError(Err.Number, Err.Description, strProcName)
Resume GetCreateOutlookObjectExit

End Function

Private Sub Class_Initialize()

Dim strProcName As String
strProcName = "clsEmailLinked.Class_Initialize"
On Error GoTo Class_Initialize_Error

If Not GetCreateOutlookObject(fOutlWasRunning) Then
End If

fMailSent = False

Class_Initialize_Exit:

On Error Resume Next
Exit Sub

Class_Initialize_Error:

Call FatalError(Err.Number, Err.Description, strProcName)
Resume Class_Initialize_Exit

End Sub

In the calling form:

Private Sub cmdOpenEmailLinked_Click()

Dim objMailNew As New clsEmailLinked

Dim strRecipient As String
Dim strSubject As String
Dim strBody As String
Dim fWasRunning As Boolean

Dim strProcName As String
strProcName = "Form_frmSendEmail.cmdOpenEmailLinked_Click"
On Error GoTo cmdOpenEmailLinked_Click_Error

strRecipient = Nz(Me![fldDelegateID].Column(2), "")
strSubject = Nz(Me![fldSubject], "")
strBody = Nz(Me![cboSelectEmailType].Column(3), "")
If Len(strBody) > 0 Then
strBody = strBody & vbCrLf & vbCrLf
End If
strBody = strBody & Nz(Me![fldAdditionalRemarks], "")

Set objMailNew = New clsEmailLinked

'=====>> fails on next statement

Set objMailNew.objNewMailLinked =
objMailNew.objOutlook.CreateItem(olMailItem)

With objMailNew.objNewMailLinked
If Len(strRecipient) > 0 Then
.Recipients.Add (strRecipient)
End If
If Len(strSubject) > 0 Then
.Subject = strSubject
Else
.Subject = "Test Test Test"
End If
If Len(strBody) > 0 Then
.Body = strBody
End If
.Display True
If objMailNew.MailSent Then
' do some stuff
End If

End With

cmdOpenEmailLinked_Click_Exit:

On Error Resume Next
Set objMailNew.objNewMailLinked = Nothing
Set objMailNew = Nothing
DoCmd.Close acForm, Me.Name
Exit Sub

cmdOpenEmailLinked_Click_Error:

Call FatalError(Err.Number, Err.Description, strProcName)
Resume cmdOpenEmailLinked_Click_Exit

End Sub

Regards,
Richard.