Looping to Email

[DMT Dave]

Hi Guy's this one is so close but 2 issues, when the emails pop up, if 14 emails are on the recordset, there appears to be maybe 2 or 3 of the emails that have the same client name or the name doesn't match the email address but the majority are correct, any idea why the same email address may mix with another record ?

I have noticed on 2 records when testing, there are 2 bookings under the same email address, would this do it ?



I would imagine that it would just generate 2 emails for that one address as the only criteria is the RemDate ?

Dim oOutlook As Outlook.ApplicationDim oEmailItem As MailItem
Dim rs As DAO.Recordset
Dim OutAccount As Outlook.Account
Dim RemDate As Date
Dim CurrDay As Date, myDay As String, DayNo As Long, OrgDate As Date, DateChange As String, MailBody As String, TimingBody As String, TimeSlot As String, CLListName As String
Dim myClient As String, FullName() As String, dte As Date, TOD As String, FriDate As Date, ConDate As Date, myGreet As String, myETA1 As String, myETA2 As String, myEmail As String
Dim BookingLink As String, RecNo As Integer


On Error Resume Next
Err.Clear
 
Set oOutlook = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set oOutlook = New Outlook.Application
End If


RemDate = Format(Me.txtTimDate, "mm/dd/yyyy")
CurrDay = DateAdd("d", -(Weekday(Me.txtDateSource) - DayNo), Me.txtDateSource)
myDay = Format(CurrDay, "dddd-dd-mmm-yyyy")
DateChange = Format(CurrDay, "dd-mm-yyyy")
FriDate = DateAdd("d", -(Weekday(Me.txtDateSource) - 6), Me.txtDateSource)
ConDate = Format(FriDate, "dddd-dd-mmm-yyyy")


dte = Format(Now(), "hh:nn")
Select Case TOD
Case Is < TimeValue("12:00")
TOD = "Good morning"
Case Is < TimeValue("17:00")
TOD = "Good afternoon"
Case Else
TOD = "Good evening"
End Select


BookingLink = "https://changed on here/active-bookings"


Set oEmailItem = oOutlook.CreateItem(olMailItem)
Set rs = CurrentDb.OpenRecordset("Select * From tblRemovals WHERE RemovalDate = #" & RemDate & "#")
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst
Do Until rs.EOF = True
RecNo = rs.Fields("RecordNo")
myETA1 = rs.Fields("ETA")
myETA2 = rs.Fields("ETA2")


CLListName = rs.Fields("Client")
FullName = Split(CLListName, " ")
Select Case UBound(FullName)
Case 0
myClient = FullName(0)
Case 1
myClient = FullName(0)
Case 2
myClient = FullName(0) & " " & FullName(2)
End Select


myGreet = TOD & " " & myClient & ","
myEmail = rs.Fields("Email")


Set oEmailItem = oOutlook.CreateItem(olMailItem)
With oEmailItem
Set OutAccount = myApp.Session.Accounts.Item(2)


TimeSlot = "We have now allocated a buffer time slot to remove your changed on here." & vbNewLine & vbNewLine & _
"Here is the allocation we are offering:" & vbNewLine & vbNewLine & _
"......................................................................................................................." & vbNewLine & _
vbTab & "Removal Date: " & Me.txtDate & vbNewLine & vbNewLine & _
vbTab & "Expected between: " & myETA1 & vbTab & "and" & vbTab & Replace(myETA2, ":00", "") & " " & "subject to your approval" & vbNewLine & vbNewLine & _
vbTab & "You can view your times online which will be updated on " & Format(ConDate, "dddd-dd-mmm-yyyy") & " " & "mid afternoon onwards" & vbNewLine & vbNewLine & _
"......................................................................................................................." & vbNewLine & _
Chr(149) & " " & "IMPORTANT NOTE" & " " & Chr(149) & vbNewLine & vbNewLine & _
"Due to a very congested phone line, to prevent us missing you, your timings are now offered online also." & vbNewLine & vbNewLine & _
"Due to our privacy policy, there is no names and address on our website that corresponds with your booking, just your unique booking number." & vbNewLine & vbNewLine & _
"Please follow this link " & BookingLink & " your login is: removed on here" & " " & "your 4 digit booking number " & "( " & RecNo & " ) will be listed" & vbNewLine & vbNewLine & _
"If you can accommodate the timings offered, please type your reference number " & "(" & RecNo & ")" & " " & "Click 'Confirm Time Button'" & vbNewLine & vbNewLine & _
"We much appreciate this as it helps us whilst our telephone lines are very busy." & vbNewLine & vbNewLine & _
"We thank you for your understanding and we look forward to assisting you" & vbNewLine & vbNewLine & _
"With our kindest regards"


MailBody = myGreet & vbNewLine & vbNewLine & _
TimeSlot
.To = myEmail
.Subject = "product Removal"
.Body = MailBody
.SendUsingAccount = OutAccount
.Display
End With
rs.MoveNext
Loop
End If
rs.Close
Set rs = Nothing
Set oEmailItem = Nothing
Set oOutlook = Nothing

[Minty]

I would create create a Debug.print of your recordset query and see the results, I would assume they aren't what you expect?

There doesn't appear any problem with your method at first glance.
I have indented it just to make it easier to follow. Maybe remove the On Error Resume Next bit in case somethiing is bombing out and messing up the loop?

Sub test()


    Dim oOutlook As Outlook.Application
    Dim oEmailItem As MailItem
    Dim rs As DAO.Recordset
    Dim OutAccount As Outlook.Account
    Dim RemDate As Date
    Dim CurrDay As Date, myDay As String, DayNo As Long, OrgDate As Date, DateChange As String, MailBody As String, TimingBody As String, TimeSlot As String, CLListName As String
    Dim myClient As String, FullName() As String, dte As Date, TOD As String, FriDate As Date, ConDate As Date, myGreet As String, myETA1 As String, myETA2 As String, myEmail As String
    Dim BookingLink As String, RecNo As Integer




    On Error Resume Next
    Err.Clear
 
    Set oOutlook = GetObject(, "Outlook.Application")
    If Err.Number <> 0 Then
        Set oOutlook = New Outlook.Application
    End If




    RemDate = Format(Me.txtTimDate, "mm/dd/yyyy")
    CurrDay = DateAdd("d", -(Weekday(Me.txtDateSource) - DayNo), Me.txtDateSource)
    myDay = Format(CurrDay, "dddd-dd-mmm-yyyy")
    DateChange = Format(CurrDay, "dd-mm-yyyy")
    FriDate = DateAdd("d", -(Weekday(Me.txtDateSource) - 6), Me.txtDateSource)
    ConDate = Format(FriDate, "dddd-dd-mmm-yyyy")




    dte = Format(Now(), "hh:nn")
    Select Case TOD
        Case Is < TimeValue("12:00")
            TOD = "Good morning"
        Case Is < TimeValue("17:00")
            TOD = "Good afternoon"
        Case Else
            TOD = "Good evening"
    End Select




    BookingLink = "https://changed on here/active-bookings"




    Set oEmailItem = oOutlook.CreateItem(olMailItem)
    Set rs = CurrentDb.OpenRecordset("Select * From tblRemovals WHERE RemovalDate = #" & RemDate & "#")
    If Not (rs.BOF And rs.EOF) Then
        rs.MoveFirst
        Do Until rs.EOF = True
            RecNo = rs.Fields("RecordNo")
            myETA1 = rs.Fields("ETA")
            myETA2 = rs.Fields("ETA2")




            CLListName = rs.Fields("Client")
            FullName = Split(CLListName, " ")
            Select Case UBound(FullName)
                Case 0
                    myClient = FullName(0)
                Case 1
                    myClient = FullName(0)
                Case 2
                    myClient = FullName(0) & " " & FullName(2)
            End Select




            myGreet = TOD & " " & myClient & ","
            myEmail = rs.Fields("Email")




            Set oEmailItem = oOutlook.CreateItem(olMailItem)
            With oEmailItem
                Set OutAccount = myApp.Session.Accounts.Item(2)




                TimeSlot = "We have now allocated a buffer time slot to remove your changed on here." & vbNewLine & vbNewLine & _
                    "Here is the allocation we are offering:" & vbNewLine & vbNewLine & _
                    "......................................................................................................................." & vbNewLine & _
                    vbTab & "Removal Date: " & Me.txtDate & vbNewLine & vbNewLine & _
                    vbTab & "Expected between: " & myETA1 & vbTab & "and" & vbTab & Replace(myETA2, ":00", "") & " " & "subject to your approval" & vbNewLine & vbNewLine & _
                    vbTab & "You can view your times online which will be updated on " & Format(ConDate, "dddd-dd-mmm-yyyy") & " " & "mid afternoon onwards" & vbNewLine & vbNewLine & _
                    "......................................................................................................................." & vbNewLine & _
                    Chr(149) & " " & "IMPORTANT NOTE" & " " & Chr(149) & vbNewLine & vbNewLine & _
                    "Due to a very congested phone line, to prevent us missing you, your timings are now offered online also." & vbNewLine & vbNewLine & _
                    "Due to our privacy policy, there is no names and address on our website that corresponds with your booking, just your unique booking number." & vbNewLine & vbNewLine & _
                    "Please follow this link " & BookingLink & " your login is: removed on here" & " " & "your 4 digit booking number " & "( " & RecNo & " ) will be listed" & vbNewLine & vbNewLine & _
                    "If you can accommodate the timings offered, please type your reference number " & "(" & RecNo & ")" & " " & "Click 'Confirm Time Button'" & vbNewLine & vbNewLine & _
                    "We much appreciate this as it helps us whilst our telephone lines are very busy." & vbNewLine & vbNewLine & _
                    "We thank you for your understanding and we look forward to assisting you" & vbNewLine & vbNewLine & _
                    "With our kindest regards"




                MailBody = myGreet & vbNewLine & vbNewLine & _
                    TimeSlot
                .To = myEmail
                .Subject = "product Removal"
                .Body = MailBody
                .SendUsingAccount = OutAccount
                .Display
            End With
            rs.MoveNext
        Loop
    End If
    rs.Close
    Set rs = Nothing
    Set oEmailItem = Nothing
    Set oOutlook = Nothing


End Sub

[Welshgasman]

I would be dumping the recordset fields in the Immediate window and see what is actually there?

[DMT Dave]

Hi guys thank you very much, will do as suggested, all the best