Using Mailitem to send multiple emails

[Dougalsworld]

Hi Folks

I have searched and searched on this forum and the web for a solution, so far to no avail.

I basically need to send on the click of a button a mail independently to several people (1 email per person)
Now I have a way to do this using a loop function using recordsets and the SendObject function...

...problem is I need to add voting buttons to this email, and this method is not compatable with this, instead if I want voting buttons i need to send the mails using the Outlook.MailItem function, but I don't know how to loop this function to send multiple emails.

My MailItem code is below, does anyone know how I can ammend it to send multiple emails from a query "qry_Mail_Booking" ???

Dim outobj As Outlook.Application
Dim outappt As Outlook.MailItem
Dim stDocName As String
Set outobj = CreateObject("outlook.Application")
Set outappt = outobj.CreateItem(olMailtItem)
With outappt
.To = [LMEmail]
.Subject = [Subject]
.MeetingStatus = olMailItem

.Recipients.ResolveAll
.Display
.Send
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!ReqSent = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"

stDocName = "ADD_Booking_New"
DoCmd.OpenQuery stDocName, acNormal, acEdit
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description

DoCmd.SetWarnings False
Me.Refresh

Many Thanks

 

[Dougalsworld]

Equally if somone knows how to use SendObject to send a voting button that would also be a way round this, although I'm pretty sure this cant be done

 

[Dougalsworld]

Ok another revision I now have found some code that looks like it should work, but fails [part the way through.
It basically looks up the query with the email addresses in and sends the first one ok but then does not move to the next record.
Instead I get the following error:

Run-Time Error '-2113666806 (8204010a)':
The item has been moved or deleted

The code I'm Using is below, the line in BOLD is where the error directs me

Private Sub btnBookCourse_Click()

Dim rsEmail As ADODB.Recordset
Dim StrEmail As String
'Dim strUpdateEmail As sring
Dim ol As New Outlook.Application
Dim olMail As Outlook.MailItem

Set olMail = ol.CreateItem(olMailItem)
Set rsEmail = New ADODB.Recordset

rsEmail.ActiveConnection = CurrentProject.Connection
rsEmail.Open "qry_Mail_Booking"

With olMail
Do While Not rsEmail.EOF
StrEmail = rsEmail.Fields("LMMail").Value 'sets email address value

.To = StrEmail
'.CC = "address1@aa.com"
'.BCC = "address2@aa.com"
'.Attachments.Add "c:\somefile.txt"
'.Attachments.Add "c:\secondfile.txt"
.Subject = "Testing"
.Body = "This is the body..."
.Send

rsEmail.MoveNext 'goes to next record

Loop 'starts whole process over again

End With

Set olMail = Nothing
Set ol = Nothing

Set rsEmail = Nothing 'closes table
'strUpdateEmail = UpdateEmail_(UpdateEmail)

End Sub