Hi All.
I have the below code which generates an automatic email based on information from a query called QueryHiresOverdue. The correct amount of emails are being generated, however the To and CC for each email is the same.
I am using a DLookup to find the To and CC for the email. Depending on the [Ward] in the QueryHiresOverdue, I should see a different To and CC.
The MSG I have is changing for each record in the query, so I was expecting the To and CC to do the same.
Can anybody spot the issue with my DLookup that is causing it to return the same value?
Thanks
Full code below if required.
I have the below code which generates an automatic email based on information from a query called QueryHiresOverdue. The correct amount of emails are being generated, however the To and CC for each email is the same.
I am using a DLookup to find the To and CC for the email. Depending on the [Ward] in the QueryHiresOverdue, I should see a different To and CC.
The MSG I have is changing for each record in the query, so I was expecting the To and CC to do the same.
Can anybody spot the issue with my DLookup that is causing it to return the same value?
Code:
.To = DLookup("[HousekeeperName]", "LookupDepartment", "Depart=Ward")
.CC = DLookup("[DeptHead]", "LookupDepartment", "Depart=Ward")Thanks
Full code below if required.
Code:
Dim db As DAO.Database
Dim REC As Recordset
Dim reportName As String
Dim criteria As String
Dim MSG As String
Dim O As Outlook.Application
Dim M As Outlook.MailItem
Dim FolderPath As String, fileName As String
Dim TotalRecords As Integer
Dim n As Integer
Dim ToAddress As String
Dim CCAddress As String
' Count records in found set
Set db = CurrentDb()
Set REC = db.OpenRecordset("QueryHiresOverdue", dbOpenDynaset)
REC.MoveLast
TotalRecords = REC.RecordCount
REC.Close
If TotalRecords > 0 Then
' Get out message
Message = "MediPool will Automatically send " & TotalRecords & _
" overdue reminder emails" _
& Chr(10) & "Do you wish to continue?"
Title = "MediPool Auto Emails"
Response = MsgBox(Message, vbOKCancel, Title)
If Response = vbCancel Then GoTo Exit_CommandOverdueEmails_Click
Set db = CurrentDb()
Set REC = db.OpenRecordset("QueryHiresOverdue", dbOpenDynaset)
For n = 1 To TotalRecords
MSG = "Your ward, " & REC("Ward") & ", currently has hire equipment that should be in use in Bed Space " & REC("BedSpaceNumber") & ". It was hired out for patient " & REC("Initials") & ", Hospital Number " & REC("HospitalNumber") & "." & "<p>" & "This hire is currently costing your Ward £" & REC("CostPerDay") & " per day, and has costed £" & REC("CostSoFar") & " in total so far." & "<p>" & "Hire Item Details:" & "<p>" & "Device Type - " & REC("DeviceType") & "" & "<p>" & "Model - " & REC("Model") & "" & "<p>" & "Supplier - " & REC("HiredFrom") & "" & "<p>" & "Serial Number - " & REC("SerialNumber") & "" & "<p>" & "Please check whether this item is still in use. If you have finished with this hire, please arrange with the Porters on Extension 1188 to return it to the Equipment Pool." & "<p>" & "Thanks" & "<p>" & "Equipment Pool" & "<p>" & "Extension 2323"
'Remember to add REFERENCE to Microsoft Outlook Object Library
Set O = New Outlook.Application
Set M = O.CreateItem(olMailItem)
With M
.BodyFormat = olFormatHTML
.HTMLBody = MSG
.To = DLookup("[HousekeeperName]", "LookupDepartment", "Depart=Ward")
.CC = DLookup("[DeptHead]", "LookupDepartment", "Depart=Ward")
.Subject = "Hire Equipment Overdue For Returning"
.Display
End With
REC.MoveNext
Next n
REC.Close
'Completed Message
Message = TotalRecords & " emails have automatically been sent by MediPool"
Title = "MediPool Auto Emails"
Response = MsgBox(Message, vbOK, Title)
Else
Exit_CommandOverdueEmails_Click:
Exit Sub
End If
