I have successfully sent an e-mail from an Access form to Outlook using the Function below, however, the .Send command only gets the e-mail to the Outlook outbox. I have to physically open Outlook which has 'Send immediately when connected' selected in order for the e-mail to actually be sent.
I have been searching for a simple vba code method to force Outlook to actually send the messages i.e. something akin to Outlook's 'Send Receive All' without success.
Can anyone offer any help please
Code:
Option Compare Database
Option Explicit
Public Function SendMail(sSubject, sMessage, sDefaultAddress, sAttachment As String) As Boolean
On Error GoTo ErrorHandler
Dim olApp As Object
Dim olMail As Object
Dim olRecipient As Object
Dim olAttachment As Object
Dim strSQL As String
Dim strAddress As String
Dim strPath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Const olMailItem = 0
Const olTo = 1
Const olBCC = 3
Const olImportanceHigh = 2
'Create the Outlook session.
Set olApp = CreateObject("Outlook.Application")
'Create the message.
Set olMail = olApp.CreateItem(olMailItem)
'Create path to location of any attachment
strPath = "C:\Temp"
'Define the recordset
Set db = CurrentDb
'Define field to be used for eMail recipients
strAddress = "EMail"
'Define SQL this is always the same source the calling form creates
'tbl_Bulk_EMail from user defined parameters
strSQL = "SELECT DISTINCT EMail FROM tbl_Bulk_EMail"
'Open a recordset to obtain recipients
Set rs = db.OpenRecordset(strSQL)
With rs
If Not .BOF And Not .EOF Then
.MoveLast
.MoveFirst
intRecordCount = rs.RecordCount
While (Not .EOF)
Set olRecipient = olMail.Recipients.Add(.Fields(strAddress))
olRecipient.Type = olBCC
.MoveNext
Wend
End If
End With
'Add the Default address if present
If sDefaultAddress > "" Then
Set olRecipient = olMail.Recipients.Add(sDefaultAddress)
olRecipient.Type = olTo
End If
With olMail
'Set the Subject, Body, and Importance of the message.
.Subject = sSubject
.Body = sMessage
.Importance = olImportanceHigh 'High importance
'Add attachment if it exists
If sAttachment > "" Then
.Attachments.Add strPath & "\" & sAttachment & ".pdf"
End If
' Resolve each Recipient's name.
For Each olRecipient In .Recipients
olRecipient.Resolve
Next
'Display the EMail for further edit
'.Display
'Email can be sent without opportunity for further edit
.Send '*******************************************************************?????
End With
'All OK so return True to the calling Form
SendMail = True
ExitFunction:
Set olRecipient = Nothing
Set olMail = Nothing
Set olApp = Nothing
Exit Function
ErrorHandler:
SendMail = False
Resume ExitFunction
End Function