Looping Emails Help

[bbrendan]

Hi All,

I hope someone can work out why my emails wont loop through the recordset. Im very 'green' when it comes to vb so be gentle

What im trying to do is loop through a table of email address to send customers confirmations. I dont want to use the Docmd.send obj as it doesnt work all the time. See http://support.microsoft.com/default.aspx?scid=kb;en-us;Q262634

Anyway Whn i try and loop it says Loop without Do. Can someone please let me know where i should be dropping the do!!!

thanks!!
-------------------------------------------------

Private Sub cmd_send_emails_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 "Select * from w_imp_email"

rsEmail.MoveFirst
Do Until rsEmail.EOF
StrEmail = rsEmail.fields("billemail").Value 'sets email address value

'loops through until the end of the table

With olMail

.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

Loop 'starts whole process over again
rsEmail.MoveNext 'goes to next record

End With

Set olMail = Nothing
Set ol = Nothing



Set rsEmail = Nothing 'closes table

----------------------

 

[cpod]

You've improperly nested your with and loop statements. Just move your "With olMail" statement to come before you "DO" statement.

 

[BukHix]

Here is a working sample for you:

Dim rsEmail As DAO.Recordset
Dim strEmail As String
Set rsEmail = CurrentDb.OpenRecordset("YourQuery")

Do While Not rsEmail.EOF
strEmail = rsEmail.Fields("EmailAddress").Value
DoCmd.SendObject , , , strEmail, , , "Subject", "Message Text"

rsEmail.MoveNext

Loop
Set rsEmail = Nothing
--------------------------------------------------

Then make sure you change these to match the names in your table/query.

"YourQuery" = Table or Query Name.
"EmailAddress" = Field in Table or Query holding the email address.

This will loop through an entire table or query sending an email to everyone in it.

 

[bbrendan]

Looping

Hi Cpod, Bukhix

Thanks both of you,

Just another question I have mod the code as cpod has suggested, but i geta new error "The item has been moved or deleted". Any ideas!!!!!

------------------------------
Private Sub cmd_send_emails_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 "Select * from w_imp_email"

With olMail
Do While Not rsEmail.EOF
StrEmail = rsEmail.fields("billemail").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

 

[cpod]

When you go in to debug what line of code is highlighted?

 

[bbrendan]

Mass Email Via ADO

Hi CPOD,

Thanks ofr your reply, I finally figured it.. I hope its useful to others....

It seems to work like a charm.

I would suggest this over the docmd.send as it has BIG issues
PS make sure you have the outlook referenced

-----------------------------------------------


Public Function Email_(Email)

Dim rsEmail As ADODB.Recordset
Dim strSQL As String
Dim strMessage As String
Dim objOutlook As New Outlook.Application
Dim objMessage As MailItem
Dim strSubject As String

Set rsEmail = New ADODB.Recordset

strSQL = "SELECT * from w_imp_email" ' this is the table containing the email addresses

rsEmail.ActiveConnection = CurrentProject.Connection
rsEmail.Open "Select * from w_imp_email"
If rsEmail.RecordCount > 0 Then
rsEmail.MoveFirst
Do While Not rsEmail.EOF

StrEmail = rsEmail.fields("billemail").Value 'sets email address value
IntOrderID = rsEmail.fields("OrderID").Value
strFirstname = rsEmail.fields("BillFirstName").Value
strLastname = rsEmail.fields("BillLastName").Value
strShipFirstname = rsEmail.fields("ShipFirstname").Value
strShipLastname = rsEmail.fields("ShipLastname").Value
strShipCompany = rsEmail.fields("ShipCompany").Value
strShipAddress = rsEmail.fields("ShipAddress").Value
strShipAddress2 = rsEmail.fields("ShipAddress2").Value
strShipCity = rsEmail.fields("ShipCity").Value
StrShipProvince = rsEmail.fields("ShipProvince").Value
strShipPostalCode = rsEmail.fields("ShipPostalCode").Value
strShipCountry = rsEmail.fields("ShipCountry").Value
strReason = rsEmail.fields("reason").Value

' here are the reason text swapped out - for defining error codes in the message body

If strReason = "INVALID NO" Then
strReason2 = "your card Number being invalid"
Else
If strReason = "INSUFFICIENT FUNDS" Then
strReason2 = "your card currently having Insufficient funds to process this transaction"
Else
If strReason = "INSUFFCIENT STOCK" Then
strReason2 = "temporary shortage of stock of the title(s) you have ordered"
End If
End If
End If

' this is where the emails are fired

Set objMessage = objOutlook.CreateItem(olMailItem)
With objMessage
.To = StrEmail
.Subject = "Lonely Planet Order Processing Query. Your Ref:" & IntOrderID
.Body = "Dear " & strFirstname & " " & strLastname & "," _
& vbCrLf & vbCrLf _
& "We are currently processing your order " & IntOrderID _
& vbCrLf _
& vbCrLf _
& "At this time we cannot proceed with despatching your order due to " & LCase(strReason2) & " to the following address" _
& vbCrLf & vbCrLf & "-----------------------------------------" _
& vbCrLf & vbCrLf & " " & strShipFirstname & " " & strShipLastname & vbCrLf & " " & strShipCompany & vbCrLf & " " & strShipAddress & vbCrLf & " " & strShipAddress2 & vbCrLf & " " & strShipCity & vbCrLf & " " & StrShipProvince & vbCrLf & " " & strShipPostalCode & vbCrLf & " " & strShipCountry & vbCrLf & vbCrLf & vbCrLf & "-----------------------------------------" _
& vbCrLf & " via standard postal services" & vbCrLf & "-----------------------------------------" & vbCrLf & vbCrLf & "Could you please contact our office or alternativley reply to this email to ensure a quick resolution. " & vbCrLf & vbCrLf & " XXXXX LTD" & vbCrLf & " XX SXXX XXX" & vbCrLf & "Kent" & vbCrLf & " XXX XXX London" & vbCrLf & " United Kingdom" & vbCrLf & " ph:" & vbCrLf & " fax: " & vbCrLf & " email:" & vbCrLf & " http://"
' .Attachments.Add = ("C:\Table2.TXT")
' .Attachments.Add = ("C:\Table3.TXT")
.Importance = olImportanceHigh 'High importance
.Send
End With

rsEmail.MoveNext
Loop
rsEmail.Close
End If
End Function