Public Sub SendOutlookMessage( _
strEmailAddress As String, _
strEmailCCAddress As String, _
strEmailBccAddress As String, _
strSubject As String, _
strMessage As String, _
blnDisplayMessage As Boolean, _
Optional strAttachmentFullPath As String)
'* Copy this code and paste it into a new Access
'* Module. Click Tools > References and make sure
'* that "Microsoft Office Outlook x.0 Object Library"
'* is checked.
'*
'* This subroutine sends an e-mail message through
'* MS Outlook. If the "blnDisplayMessage" parm is
'* set to "False", the message is placed in the
'* Outlook Outbox. "True" displays the message, and
'* user will have to click "Send" to send it.
'*
'* Ex.:
'*
'* SendOutlookMessage _
'* "john@doe.com", _
'* "ccJane@doe.com", _
'* "bccSue@doe.com", _
'* "Subject", _
'* "Body of Message", _
'* False, _
'* "C:\My Documents\MyAttachmentFile.txt"
Dim objApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecipient As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim blnOutlookInitiallyOpen As Boolean
Dim strProcName As String
On Error Resume Next
strProcName = "SendOutlookMessage"
blnOutlookInitiallyOpen = True
Set objApp = GetObject(, "Outlook.Application")
If objApp Is Nothing Then
Set objApp = CreateObject("Outlook.Application")
'* Outlook wasn't open when this function started.
blnOutlookInitiallyOpen = False
End If
If Err <> 0 Then Beep: _
MsgBox "Error in " & strProcName & " (1): " _
& Err.Number & " - " & Err.Description: _
Err.Clear: _
GoTo Exit_Section
'Create the message
Set objOutlookMsg = objApp.CreateItem(olMailItem)
If Err <> 0 Then Beep: _
MsgBox "Error in " & strProcName & " (2): " _
& Err.Number & " - " & Err.Description: _
Err.Clear: _
GoTo Exit_Section
With objOutlookMsg
Set objOutlookRecipient = .Recipients.Add(strEmailAddress)
objOutlookRecipient.Type = olTo
If strEmailCCAddress = "" Then
Else
Set objOutlookRecipient = .Recipients.Add(strEmailCCAddress)
objOutlookRecipient.Type = olCC
End If
If strEmailBccAddress = "" Then
Else
Set objOutlookRecipient = .Recipients.Add(strEmailBccAddress)
objOutlookRecipient.Type = olBCC
End If
.subject = strSubject
.Body = strMessage
'* Add attachments
If Not IsMissing(strAttachmentFullPath) Then
If Trim(strAttachmentFullPath) = "" Then
Else
Set objOutlookAttach = .Attachments.Add(strAttachmentFullPath)
If Err <> 0 Then Beep: _
MsgBox "Error in " & strProcName & " (3): " _
& Err.Number & " - " & Err.Description: _
Err.Clear: _
GoTo Exit_Section
End If
End If
If blnDisplayMessage Then
.Display
Else
'* Send message by putting it in the Outbox
.Send
End If
End With
If Err <> 0 Then Beep: _
MsgBox "Error in " & strProcName & " (99): " _
& Err.Number & " - " & Err.Description: _
Err.Clear: _
GoTo Exit_Section
Exit_Section:
On Error Resume Next
If Not blnOutlookInitiallyOpen Then
objApp.Quit
End If
Set objApp = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecipient = Nothing
On Error GoTo 0
End Sub
