Emailing loop not quite working

[Malcy]

Hi
I am trying to set up a procedure that loops through a recordset and sends an email to each record in the recordset.
The query underlying the recordset selects on a date criterion and also if a field, bNotif is 0.
I have built a continuous form based on the underlying qryExpDrug and there is a button saying "send emails" on the form. The relevant bit of the code I have managed to get to is this

    rst.Open "qryExpDrug", cnn, adOpenDynamic, adLockOptimistic
        With rst
            Do While Not .EOF
                .MoveLast
                .MoveFirst
                
                    DoCmd.SendObject , , , Me!txtGpEm, , , "XXX - Issued drug expiry advice", "Dear " & Me!txtGpName & "," & CR & "On " & Me!txtIssue & " we issued you with " & Me!txtQty & " " & Me!txtDrugFormat & " of " & Me!txtDrugName & ". The manufacturer was " & Me!txtMan & " and the batch number was " & Me!txtBatch & ". This batch was has an exiry date of " & Me!txtExp & " which is now approaching." & CR & CR & "XXX" & CR & "XXX" & CR & "XXX" & CR & "XXX", , True
                    
                        .Fields("bNotif") = -1
                        .Update
                        .MoveNext
                    Me.Requery
                Loop
            .Close
        End With

It does exactly what I want it to on the first run through in that the first and second emails are exactly as expected. However once I send the email for the second record it seems to stick on it and the bNotif field does not update.
Can anyone show me what I have got wrong here or alternatively point me in a better direction?
ANy help much appreciated
Best wishes

 

[john471]

Without looking too deeply at it...

Suspect you want to move your .movelast, .movefirst to outside the loop

i.e. change

Do While Not .EOF
.MoveLast
.MoveFirst

to

.MoveLast
.MoveFirst
Do While Not .EOF

otherwise you are only ever processing the first record over and over again.

Although... your indentation in your posted code leads me to suspect you have deleted lines of code that you think are irrelevant... if that is the case it maks it very hard to say.

Have you tried stepping through in debug mode ?

Regards

John.

 

[Malcy]

Thanks John
Moving those lines did it. Sure they were there at first but that was before I put in the Me.Requery.
Anyway works a treat now.
Thanks for the help.

 

[atisz]

Question

Would you be so kinde to poste a sample of your db?

Thanx.

 

[PC User]

Emailing loop

A few months ago I had the same problem. This email loop includes a lot of things. I hope this is helpful.

Public Function EmailLoop()
On Error GoTo Message_Err
'On Error Resume Next
    Dim strErrMsg As String 'For Error Handling
    Dim olApp As New Outlook.Application
    Dim olNameSpace As Outlook.NameSpace
    Dim olMail As Outlook.MailItem
    Dim oleMsg As Object
    'Data taken from listbox
    Dim strFileName As String
    Dim strSender As String
    Dim strReciprient As String, strResponsibleParty As String  'These are the same person
    Dim strProject As String 'ActionDescription
    Dim strFacility As String
    Dim strFrequency As String
    Dim strDueDate As String
    'Parameters for recordset
    Dim db As DAO.Database
    Dim rst As DAO.Recordset
    Dim intCount As Integer
    Dim frm As Form
    Dim sfN As Form 'Program Notification SubForm
    Set frm = Forms!frmMainEntry.Form
    Set sfN = frm.[fctlNotifications].Form
    Set db = CurrentDb()
    Set rst = db.OpenRecordset("qselNotifications")

            'Count of unsent e-mails
            intCount = DCount("ProgramID", "tsubProgramList", "Selected = True")

    If intCount > 0 Then
        If MsgBox("You have " & intCount & " notification e-mails to send?" & vbCrLf & "Send them now?", vbYesNo + vbQuestion, "Email Notification") = vbNo Then
           Exit Function
    Else

    End If

rst.MoveFirst
Do Until rst.EOF

        strProject = rst!ProgramDescription
        strFacility = rst!Facility
        strDueDate = Nz(rst!DueDate, "")
        strFrequency = rst!FrequencyOfService
        strReciprient = rst!EmailAddress
        strResponsibleParty = rst!ResponsibleParty
        strSender = frm!txtWelcome

Set olNameSpace = olApp.GetNamespace("MAPI")
Set olMail = olApp.CreateItem(olMailItem)
'Attachment = "Full path of whatever file you want to attach"

    With olMail
        .To = strReciprient
        '.BCC = "MLandgaard@mwdh2o.com" & "; " & "OPerez@mwdh2o.com"   'Send a copy to WHS managers
        .Subject = "Notification Of Compliance Requirement"
        .Body = vbCrLf & vbCrLf & vbCrLf & _
                "To:  " & strResponsibleParty & vbCrLf & vbCrLf & vbCrLf & _
                "This is to notify you that the requirement for " & strProject & " at the " & _
                strFacility & " is due on " & strDueDate & "." & vbCrLf & _
                strProject & " is required " & strFrequency & "." & vbCrLf & vbCrLf & vbCrLf & _
                "Keep On Track With Safety" & vbCrLf & strSender
        .Importance = olImportanceHigh  'High importance
        '.ReadReceiptRequested = True
        '.Attachment.Add Attachment
        .Send
    End With
rst.MoveNext
Loop
rst.Close
Set rst = Nothing
db.Close
Set db = Nothing
'============= Remove selection from list.
        CurrentDb.Execute "UPDATE tsubProgramList SET tsubProgramList.Selected = No;", dbFailOnError
'==========================================

'Run update to update the sent mail check box
'    DoCmd.SetWarnings False
'    DoCmd.RunSQL "UPDATE tblMapOutcomes SET tblMapOutcomes.ysnSentByMailToStaff = -1 WHERE (((tblMapOutcomes.ysnSentByMailToStaff)=0))"
'    DoCmd.SetWarnings True
    MsgBox "All selected email notifications have been sent", vbInformation, "Thank You"
   End If
   
        Call LogProgramEmail
        
Message_Exit:
    Set olApp = Nothing
    Set olMail = Nothing
    Set oleMsg = Nothing
Exit Function

Message_Err:
    Select Case Err
        Case Else
            strErrMsg = strErrMsg & "Error #: " & Format$(Err.Number) & vbCrLf & vbCrLf
            strErrMsg = strErrMsg & "Error Description: " & Err.Description & vbCrLf
            MsgBox strErrMsg, vbInformation, "Message"
            Resume Message_Exit
    End Select
End Function

Good Luck,
PC