Looping code for an E mail function

[monplankton]

Hi, Not used loop function before and I'm struggling to understand how to set it up on my code.All works but does scroll to next record and repeats the code. Any help much appreciated.

Dim db As Database
Set db = CurrentDb
Dim recRework As DAO.Recordset
Set recRework = db.OpenRecordset("qry_list_of_jobs")
Do While Not recRework.EOF
If IsNull(Me.[FirstReminder]) And Date > Me.Threeweeks Then
    
 Dim objOutlook As Outlook.Application, objMailItem As MailItem
  Set objOutlook = New Outlook.Application
  Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
    .to = Me.LastName & ", " & Me.FirstName
    .CC = "[EMAIL="graham.atkins@uwclub.net"][COLOR=#0000ff]graham.atkins@uwclub.net[/COLOR][/EMAIL]"
    .Subject = "3 week Reminder"
    .Body = "Hi " & [FirstName] & "," & vbCrLf & "You currently have an ongoing rework on the Rework Management System." & " " & [Part Description] & "," & " " & [Rework Activity] & " " & "reworks order number" & " " & [WO Number] & " " & ", RCS Number" & " " & [RCS Number] & vbCrLf & "This rework is due to expire in 3 weeks time on " & [Planned Finish] & ". As you are aware, if the rework is to continue then a rework extension request should be raised and approved. Can you please ensure a rework extension request is raised and approved prior to this date." & vbCrLf & "Regards" & vbCrLf & "PQA Admin"
    .Send
    End With
    
    Set objMailItem = Nothing
    Set objOutlook = Nothing
  
  Me.[FirstReminder] = Date
  
  
  ElseIf IsNull(Me.[SecondReminder]) And Date > Me.Twoweeks Then
    
    
 Set objOutlook = New Outlook.Application
  Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
    .to = Me.LastName & ", " & Me.FirstName
    .CC = "[EMAIL="graham.atkins@uwclub.net"][COLOR=#0000ff]graham.atkins@uwclub.net[/COLOR][/EMAIL]"
    .Subject = "2 week Reminder"
    .Body = "Hi " & [FirstName] & "," & vbCrLf & "Following our previous reminder, you currently have an ongoing rework on the Rework Management System." & " " & [Part Description] & "," & " " & [Rework Activity] & " " & "reworks order number" & " " & [WO Number] & " " & ", RCS Number" & " " & [RCS Number] & vbCrLf & "This rework is due to expire in Two weeks time on " & [Planned Finish] & ". If this rework is to continue then a rework extension request should be raised and approved prior to this date." & vbCrLf & "Regards" & vbCrLf & "PQA Admin"
    .Send
    End With
    
    Set objMailItem = Nothing
    Set objOutlook = Nothing
  
  Me.[SecondReminder] = Date
  
 ElseIf IsNull(Me.[ThirdReminder]) And Date > Me.Oneweek Then
    
 
  Set objOutlook = New Outlook.Application
  Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
    .to = Me.LastName & ", " & Me.FirstName
    .CC = Me.SSecond & ", " & Me.SFirst & ";William.woodhouse@nissan-nmuk.co.uk;David.hambleton@nissan-nmuk.co.uk;ian.taylor@nissan-nmuk.co.uk;Tony.wardropper@nissan-nmuk.co.uk"
    .Subject = "Rework Order"
    .Body = "Hi " & [FirstName] & "," & vbCrLf & "Following our 2 previous reminders, you currently have an ongoing rework on the Rework Management System." & " " & [Part Description] & "," & " " & [Rework Activity] & " " & "reworks order number" & " " & [WO Number] & " " & ", RCS Number" & " " & [RCS Number] & vbCrLf & "Please be informed that this rework is now currently one week away from its expiry date of " & [Planned Finish] & vbCrLf & "PQA Inspection have yet to receive a rework extension request." & vbCrLf & "If the rework is to continue can you please submit an approved extension request within three working days." & vbCrLf & "Regards," & vbCrLf & "PQA Admin"
    .Send
    End With
    
    Set objMailItem = Nothing
    Set objOutlook = Nothing
  
  Me.[ThirdReminder] = Date
  
  ElseIf IsNull(Me.[Final Reminder]) And Date > Me.Twodays Then
    
    
    Set objOutlook = New Outlook.Application
  Set objMailItem = objOutlook.CreateItem(olMailItem)
With objMailItem
    .to = Me.LastName & ", " & Me.FirstName
    .CC = Me.SSecond & ", " & Me.SFirst & ";" & Me.MSecond & ", " & Me.MFirst & ";[EMAIL="graham.atkins@uwclub.net"][COLOR=#0000ff]graham.atkins@uwclub.net[/COLOR][/EMAIL]"
    .Subject = "24 Hour Reminder"
    .Body = "Hi " & [FirstName] & "," & vbCrLf & "As mentioned in previous e-mail correspondence, PQA Inspection have yet to receive a formal rework extension request for" & " " & [Part Description] & "," & " " & [Rework Activity] & " " & "reworks order number" & " " & [WO Number] & " " & ", RCS Number" & " " & [RCS Number] & " " & "which is now 24hrs from expiry.If the rework is to continue then an extension request must be received within the next 24hrs." & vbCrLf & "Failure to comply with this notification will result in the termination of the rework activity and the removal of the resource performing the operation tomorrow." & vbCrLf & "Regards" & vbCrLf & "PQA Admin"
    .Send
    End With
    
    Set objMailItem = Nothing
    Set objOutlook = Nothing
  
  Me.[Final Reminder] = Date
  
  
  recRework.MoveNext
  
  Loop
  
  
  recRework.Close
  Set recRework = Nothing
 
 End If
 
  
  
End Sub

 

[pbaldy]

All of the "Me." references are getting values from the form, not the recordset. To get a value from the recordset:

recRework![FirstReminder]

 

[monplankton]

Thanks for that Paul I'll rectify that problem and give it a go. Did the rest of the code look right? i.e. the do While and the loop?

Graham

 

[pbaldy]

Only glanced at it, the only issue I saw was this type of thing:

Me.[SecondReminder] = Date

If you're trying to update the recordset (the underlying data), then:

recRework.Edit
recRework![SecondReminder] = Date()
recRework.Update

 

[monplankton]

Hi Paul, Took on board all your points and it works as it should barring one section. In the body of the E mail I've referenced the persons name in the query but it doesn't recognise it

.Body = "Hi " & recRework!FirstName & "," & vbCrLf & "Following our 2 previous reminders

Any ideas?

Graham

 

[pbaldy]

Looks okay, other than missing quotes at the end. Are you sure the field is in the query, and has a value?

 

[monplankton]

Hi Paul, ?Tried everything I know just comes back saying that (Firstname) Compile error: External name not defined.

The only think different about this is it is part of the mail body text!

 

[pbaldy]

Shouldn't matter. Can you post the db here?

 

[monplankton]

Hi Paul, It's working. Had to enclose all the body fields in () to get it to recognise it as a field and use my form to run the code. Works exactly how I want it to. Thanks for the help

 

[pbaldy]

Not sure what you mean or why they would be required, but glad you got it sorted.

 

[monplankton]

Hi again Paul. A lad working with me is having a problem with code in Access 2010. The code keep failing with a n error message stating Error 3066 at least one destination required. Would you give a quick look to see if there's any thing obvious we are missing?

Private Sub cmdEmailSupplierClaims_Click()
On Error GoTo Err_cmdEmailSupplierClaims_Click

If Me![ClaimContacts subform]![EmailAddress] = "Y" Then
ElseIf Me![ClaimContacts subform]![CCEmailAddress] <> "none" Then
End If

Dim strTargetFolder As String


strTargetFolder = CurrentProject.path
DoCmd.OutputTo acOutputQuery, "Qry_HistoryCard_Insp_5", "ExcelWorkbook(*.xlsx)", strTargetFolder & "\History Card.xlsx", False, "", , acExportQualityPrint
DoCmd.OutputTo acOutputQuery, "Qry_Disposed_Cost3", "ExcelWorkbook(*.xlsx)", strTargetFolder & "\Part Reject Cost.xlsx", False, "", , acExportQualityPrint
DoCmd.OutputTo acOutputQuery, "Qry_MasterRAN", "ExcelWorkbook(*.xlsx)", strTargetFolder & "\\RAN List.xlsx", False, "", , acExportQualityPrint


Dim objoutlook As Outlook.Application, objMailItem As MailItem

Set objoutlook = New Outlook.Application
Set objMailItem = objoutlook.CreateItem(olMailItem)

With objMailItem

.To = Me![ClaimContacts subform]![EmailAddress]
.CC = Me![ClaimContacts subform]![CCEmailAddress]
.Subject = "Monthly Monetary Claim Reports "
.Body = "Please see the attached documents, detailing the inspection and part reject details from the previous month." & vbCrLf & vbCrLf & "Regards," & vbCrLf & "NMUK Claims Team"
.Attachments.Add strTargetFolder & "\History Card.xlsx"
.Attachments.Add strTargetFolder & "\Part Reject Cost.xlsx"
.Attachments.Add strTargetFolder & "\RAN List.xlsx"
.Display
End With

Set objMailItem = Nothing
Set objoutlook = Nothing

Dim path As String

path = strTargetFolder & "\History Card.xlsx"
Kill (path)

path = strTargetFolder & "\Part Reject Cost.xlsx"
Kill (path)

path = strTargetFolder & "\RAN List.xlsx"
Kill (path)

Exit_cmdEmailSupplierClaims_Click:
Set objMailItem = Nothing
If Not objoutlook Is Nothing Then objoutlook.Quit
Set objoutlook = Nothing
Exit Sub

Err_cmdEmailSupplierClaims_Click:
MsgBox "cmdEmailSupplierClaims_Click Error: " & Err.Number & ": " & Err.Description
Resume Exit_cmdEmailSupplierClaims_Click
End Sub

 

[pbaldy]

On what line? You may have to comment out the On Error line temporarily.