MS Access setting outlook reminders from a DAO recordset

Joined
Jan 5, 2017
Messages
1
Reaction score
0
Hello, this is my first post so forgive me if it seems a little unclear. I am not a software developer; I am just trying to improve on an existing MS access data base. My question is:

I have a table which contains contractor names and there are corresponding contract expiry dates. There is some VBA code that runs (on load see below) and sends an MS Outlook Calendar reminder to my computer with a 6-week notice before the expiry date so renewal quotes can be requested. This works fine and sends a single outlook reminder for each contract renewal. However, a contractor may have more than one contract. I would like to group the contract details and place them into one reminder for each contractor. I cannot figure out how to alter the VBA code to do this; I am well out of my depth. Any ideas? Here’s my code and example data (in the attached word document):


Code:


Private Sub Form_Load()

' Declare record query variables
Dim db As DAO.Database
Dim RS As DAO.Recordset
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim SQLquery As String

' Define SQL query
SQLquery = "SELECT ContractOrder.[ContractorID], ContractOrder.[SiteID], ContractOrder.[SystemName], " _
& "ContractOrder.[ContractStart] , ContractOrder.[ContractEnd], ContractOrder.[AddedToOutlook] " _
& "FROM ContractOrder " _
& "WHERE ((DateDiff('d', Now(), (ContractOrder.ContractEnd))) <= 170) AND ((ContractOrder.Quote)=False) AND ((ContractOrder.AddedToOutlook)=False) " _
& "AND (((ContractOrder.[ContractorID]) In (SELECT [ContractorID] FROM [ContractOrder] As Tmp GROUP BY [ContractorID],[SiteID] HAVING Count(*)>0 And [SiteID] = [ContractOrder].[SiteID]))) " _
& "ORDER BY ContractOrder.[ContractorID], ContractOrder.[SiteID]"

''On Error GoTo ErrorHandler
Set db = CurrentDb
Set RS = db.OpenRecordset(SQLquery, dbOpenDynaset)
' If there are no contract due to expire
If RS.RecordCount = 0 Then: MsgBox "No contract due to expire": Exit Sub

' Loop while end of file is false
Do While Not RS.EOF()
' Set outlook objects
If RS("AddedToOutlook") = False Then
Set OutObj = CreateObject("outlook.application")
Set OutAppt = OutObj.CreateItem(olAppointmentItem)
With OutAppt
.Start = Nz(RS("ContractEnd") - 50, "")
.Subject = RS("ContractorID") & " Contract Renewal Quote "
.Body = "Hello," & Chr(10) & Chr(10) & "Would you be able to send contract renewal quote/s, covering the period " & Nz(RS("ContractStart") + 365, "") & " to " & Nz(RS("ContractEnd") + 365, "") & " for the following: " & Chr(10) & Chr(10) & RS("SystemName")
.Location = RS("SiteID")
.ReminderMinutesBeforeStart = DateAdd("n", 2, Now)
.ReminderSet = True
.Save
' Update table field "AddedToOutlook"
RS.Edit
RS("AddedToOutlook") = True
RS.Update
End With
Set OutObj = Nothing
Set OutAppt = Nothing
End If
RS.MoveNext
Loop

''''ErrorHandler:
''''MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
''''Exit Sub

' Close & set recordset plus database connection to nothing
RS.Close
db.Close
Set db = Nothing
Set RS = Nothing
End Sub


Data:

e.g. 6 records from 3 contractors (each produces a single outlook reminder – 6 reminders; I would like 3 reminders one for contractor A, B & C):


Contractor Site System

A 1 cctv
A 1 Induction Loop
A 1 PA system
B 1 Window Clean
B 2 Window Clean
C 1 Pest Control

Thanks for taking the trouble to look.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top