Automation - Email to multiple recipients

[Guest]

I'm using the following code to send an email with an attachment to mulitple
users, but I keep receiving an undeliverable notification from Exchange.
The code works fine if there is only one recipient. The notification makes
reference to the delimiter I'm using, which in this case is a semi colon.
Any help would be great.
Thanks

Here's the code:

Option Compare Database
Option Explicit
Public strEmailTO As String, strEmailCC As String, strEmailBCC As String

Public Function fnEmailRecip(strField As String)
Dim db As database
Dim rsEmail As Recordset
Dim strTOsql As String, strCCsql As String, strBCCsql As String

strEmailTO = ""
strEmailCC = ""
strEmailBCC = ""
'TO list string
strTOsql = "SELECT Email.EmailAddress FROM Email WHERE (((Email." &
strField & ")=1))"
'CC list string
strCCsql = "SELECT Email.EmailAddress FROM Email WHERE (((Email." &
strField & ")=2))"
'BCC list string
strBCCsql = "SELECT Email.EmailAddress FROM Email WHERE (((Email." &
strField & ")=3))"

Set db = CurrentDb()
'Make the TO list
Set rsEmail = db.OpenRecordset(strTOsql)
If rsEmail.BOF And rsEmail.EOF Then
strEmailTO = ""
Else
rsEmail.MoveFirst
Do Until rsEmail.EOF
strEmailTO = strEmailTO & rsEmail![EmailAddress] & "; "
rsEmail.MoveNext
Loop
End If
rsEmail.Close

'Remove the unneeded trailing characters.
If strEmailTO <> "" Then
strEmailTO = Left(strEmailTO, (Len(strEmailTO) - 2))
End If

'Make the CC list
Set rsEmail = db.OpenRecordset(strCCsql)
If rsEmail.BOF And rsEmail.EOF Then
strEmailCC = ""
Else
rsEmail.MoveFirst
Do Until rsEmail.EOF
strEmailCC = strEmailCC & rsEmail![EmailAddress] & "; "
rsEmail.MoveNext
Loop
End If
rsEmail.Close

'Remove the unneeded trailing characters.
If strEmailCC <> "" Then
strEmailCC = Left(strEmailCC, (Len(strEmailCC) - 2))
End If

'Make the BCC list
Set rsEmail = db.OpenRecordset(strBCCsql)
If rsEmail.BOF And rsEmail.EOF Then
strEmailBCC = ""
Else
rsEmail.MoveFirst
Do Until rsEmail.EOF
strEmailBCC = strEmailBCC & rsEmail![EmailAddress] & "; "
rsEmail.MoveNext
Loop
End If
rsEmail.Close

'Remove the unneeded trailing characters.
If strEmailBCC <> "" Then
strEmailBCC = Left(strEmailBCC, (Len(strEmailBCC) - 2))
End If

End Function


Sub SendMessage(Optional AttachmentPath)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment

' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")

' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)

With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(strEmailTO)
objOutlookRecip.Type = olTo

' Add the CC recipient(s) to the message.
' Set objOutlookRecip = .Recipients.Add(strEmailCC)
' objOutlookRecip.Type = olCC

' Add the BCC recipient(s) to the message.
' Set objOutlookRecip = .Recipients.Add(strEmailBCC)
' objOutlookRecip.Type = olBCC


' Set the Subject, Body, and Importance of the message.
.Subject = " Multiple recipients test"
.Body = "Body text goes here." & vbCrLf & "There should also be an
attachment." & vbCrLf & vbCrLf
.Importance = olImportanceHigh 'High importance
.OriginatorDeliveryReportRequested = False 'delivery confirmation
.ReadReceiptRequested = False 'read confirmation

' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If

' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
.Send

End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub