467,913 Members | 1,774 Online
Bytes | Developer Community
New Post

Home Posts Topics Members FAQ

Post your question to a community of 467,913 developers. It's quick & easy.

Do Until Loop not executing email to all records in a recordset

Bit
I am attempting to perform a Do Until...loop which should search all records in a given recordset while looking for an email address from a particular field. A separate field in a table that has a null value will update when the loop is executed. My problem is that everything else is working except for when the email is sent, it only sends an email based on the information in the last row of the recordset. I believe the issue has something to do with my Do Until...loop. Can anyone offer fresh eyes on my code to see if I'm missing something from the loop?
Expand|Select|Wrap|Line Numbers
  1. Sub SecondEmailAttempt()
  2.  
  3. Dim db As dao.Database
  4. Dim rs As dao.Recordset
  5. Dim fld As dao.Field
  6.  
  7. Dim emailTo As String
  8. Dim emailSubject As String
  9. Dim emailText As String
  10. Dim UPDATE As String
  11. Dim Edit As String
  12. Dim strCompleted As String
  13. Dim strMessage As String
  14.  
  15. Dim oApp As New Outlook.Application
  16. Dim oMail As Outlook.MailItem
  17. Dim oStarted As Boolean
  18. Dim EditMessage As Object
  19.  
  20. Dim qdf As QueryDef
  21.  
  22. On Error Resume Next
  23. Set oApp = GetObject(, "Outlook.Application")
  24. On Error GoTo 0
  25. If oApp Is Nothing Then
  26.     Set oApp = CreateObject("Outlook.Application")
  27.     oStarted = True
  28. End If
  29.  
  30. Set db = CurrentDb
  31. On Error GoTo EricHandlingError
  32. Set rs = db.OpenRecordset("SELECT * FROM ProductRequestForm_Eric WHERE SecondEmailDate Is Null AND FirstEmailDate <= Date()-7")
  33.  
  34. If Not (rs.BOF And rs.EOF) Then
  35.  
  36. rs.MoveLast
  37. rs.MoveFirst
  38. Do Until rs.EOF = True
  39.  
  40.     emailTo = (rs.Fields("SubmitterEmail").Value)
  41.     'emailTo = Trim(rs.Fields("SubmitterEmail").Value) & " <"
  42.  
  43.     emailSubject = "Second Email Attempt"
  44.  
  45.     emailText = Trim("Hello " & rs.Fields("SubmitterFirstName").Value) & "," & vbCrLf
  46.  
  47.         emailText = emailText & "You have recently used an item that is undergoing evaluation. " & _
  48.                "Please Click the link below to tell us about your experience with the" & rs.Fields("ProductDescription").Value & "." & _
  49.                 "You should receive an email each time you use an item under evaluation until the " & _
  50.                 "evaluation is complete. Lack of compliance could impact the decisions made on items under evaluation." & vbCrLf
  51.         If (IsNull(rs.Fields("SecondEmailDate").Value)) Then
  52.         rs.Edit
  53.         rs.Fields("SecondEmailDate").Value = Date
  54.         rs.UPDATE
  55.  
  56.     End If
  57.  
  58.     rs.MoveNext
  59. Loop
  60.  
  61.         'rs.MoveFirst
  62.     Set oMail = oApp.CreateItem(0)
  63.  
  64.     With oMail
  65.         .To = emailTo
  66.         .Subject = emailSubject
  67.         .Body = emailText
  68.         '.Send
  69.         DoCmd.SendObject acSendForm, "ProductRequestForm", acFormatXLS, emailTo, , , emailSubject, emailText, False
  70.         DoCmd.SetWarnings (False)
  71.  
  72.      End With
  73.  
  74. Exit Sub
  75.  
  76.     rs.Close
  77.  
  78. Set rs = Nothing
  79. Set db = Nothing
  80.  
  81. If oStarted Then
  82.     oApp.Quit
  83. End If
  84.  
  85. Set oMail = Nothing
  86. Set oApp = Nothing
  87. EricHandlingError: MsgBox "There is no record to process in second date", vbOKOnly Exit Sub End If
  88.  
  89. End Sub
4 Weeks Ago #1
  • viewed: 1377
Share:
2 Replies
NeoPa
Expert Mod 16PB
Hi. Welcome to Bytes.com.

I've updated your post to show the code properly, but have you even tried to compile it? That should be your first step.

Something is wrong with the code you posted in as much as it doesn't conform to the basic standards of VBA code. This may be because you made a mistake copying it from your project, or maybe because it's just got serious problems. Either way, you should always use Copy & Paste to transfer code across and always compile it first.

The compilation will pick up the obvious problems, like your last line, and Copy & Paste will ensure nobody wastes their time debugging what are simply transfer competence issues.

Code indenting is also very important - but must be done consistently and with logic. Without that the information that it's there to impart is actually misleading and causes more trouble than otherwise.

Perhaps another try showing more care and attention so that our experts only have to focus on the code's actual problems is called for here. You can also edit the OP (Original Post) if that's easier. We can pick up when we have a reliable copy of what you're working with.
4 Weeks Ago #2
twinnyfo
Expert Mod 2GB
OK - I've got some time............

First, review this article: Sending e-mail via Outlook, and set up a module to do so.

Second, as NeoPa said, your code is a disaster (he didn't say, that, but I won't mince words). Here is how I would approach your code--then at least you will be able to troubleshoot things a bit better.

Expand|Select|Wrap|Line Numbers
  1. Public Sub SecondEmailAttempt()
  2. On Error GoTo EH:
  3.     Dim db              As DAO.Database
  4.     Dim rst             As DAO.Recordset
  5.     Dim strSQL          As String
  6.     Dim strSendTo       As String
  7.     Dim strSubject      As String
  8.     Dim strEMailBody    As String
  9.  
  10.     strSQL = _
  11.         "SELECT * " & _
  12.         "FROM ProductRequestForm_Eric " & _
  13.         "WHERE SecondEmailDate Is Null " & _
  14.             "AND FirstEmailDate <= #" & Date - 7 & "#;"
  15.     Set db = CurrentDb()
  16.     Set rst = db.OpenRecordset(strSQL)
  17.     With rst
  18.         If Not (.BOF And .EOF) Then
  19.             Call .MoveFirst
  20.             Do While Not .EOF
  21.                 strSendTo = !SubmitterEmail
  22.                 strSubject = "Second Email Attempt"
  23.                 strEMailBody = _
  24.                     "Hello " & !SubmitterFirstName & "," & vbCrLf & _
  25.                     "You have recently used an item that is undergoing " & _
  26.                     "evaluation. Please Click the link below to tell us " & _
  27.                     "about your experience with the" & _
  28.                     !ProductDescription & ". You should receive an email " & _
  29.                     "each time you use an item under evaluation until the " & _
  30.                     "evaluation is complete. Lack of compliance could " & _
  31.                     "impact the decisions made on items under evaluation."
  32.                 Call .Edit
  33.                 !SecondEmailDate = Date
  34.                 Call .UPDATE
  35.  
  36.                 'Generate and Display the E-Mail
  37.                 Call SendAnEMail(olSendTo:=strSendTo, _
  38.                                  olSubject:=strSubject, _
  39.                                  olEMailBody:=strEMailBody, _
  40.                                  olDisplay:=True)
  41.                 Call .MoveNext
  42.             Loop
  43.         End If
  44.     End With
  45.  
  46. ExitSub:
  47.  
  48.     rst.Close
  49.     db.Close
  50.     Set rst = Nothing
  51.     Set db = Nothing
  52.  
  53. EH:
  54.     MsgBox _
  55.         "There was an error sending the e-mail!" & _
  56.         vbCrLf & vbCrLf & _
  57.         Err.Number & vbCrLf & _
  58.         Err.Description, vbOKOnly
  59.     GoTo ExitSub
  60. End Sub
If you receive any errors now, let us know and then we will be able to address more succinctly.

Hope this hepps!
4 Weeks Ago #3

Post your reply

Sign in to post your reply or Sign up for a free account.

Similar topics

8 posts views Thread by Eric | last post: by
15 posts views Thread by shannon | last post: by
4 posts views Thread by Madhavi | last post: by
By using this site, you agree to our Privacy Policy and Terms of Use.