DomFino
11-24-2004, 07:19 PM
I have, with the help of folks on this site and others, managed to create code that basically is a tickler file system that sends emails automatically when certain dates arrive.
Anyway, as I look at the code I am thinking there might be a better way to do this by using less code. For example, I have four sections of code for each of the four quarters. I was wondering if this could be shortened to one by using variables? As I said, with the help of folks on this site, I managed to accomplish this in the SQL statement that runs to select the records to process through email.
I know this is an odd request, but I am looking for any suggestions or comments as to how the code could be shortened or made more efficient. I believe in code reviews as they tend to make things much better for all involved. Plus, I get to learn from the experts.
Thanks in advance to anyone who decides to read the following code and comment.
Dom
Option Compare Database
Option Explicit
'TicklerDT - date - Date to send reminder
'TicklerReason - memo - Reason to check the record
'TicklerPerson - text - person to send reminder to
'TicklerSent - yes/no - checked when the code issues the reminder.
'Note - need to set a reference to DAO and to your version of Outlook before using the code
Private Sub Form_Load()
'call the routine to check for ticklers that are due
CheckForTicklers
End Sub
Private Sub CheckForTicklers()
'checks to see if the given user is due for a reminder about a particular grant
On Error GoTo ErrorHandler
'create a recordset of all unsent ticklers this user has set
Dim rstCurrent As Recordset
Dim strSQL As String
Dim strSQLtest As String
Dim strUserName As String
Dim db As Database
Dim curr_rec As String
'set tickler dates and report due dates for the current year
Dim yr As Long
yr = Year(Now())
Me.txtYear.Value = Year(Now())
Dim ReportDueDT1 As Date
Dim ReportDueDT2 As Date
Dim ReportDueDT3 As Date
Dim ReportDueDT4 As Date
Dim TicklerDT1 As Date
Dim TicklerDT2 As Date
Dim TicklerDT3 As Date
Dim TicklerDT4 As Date
ReportDueDT1 = "1/15/" & Me.txtYear.Value
ReportDueDT2 = "4/15/" & Me.txtYear.Value
ReportDueDT3 = "7/15/" & Me.txtYear.Value
ReportDueDT4 = "10/15/" & Me.txtYear.Value
TicklerDT1 = "1/1/" & Me.txtYear.Value
TicklerDT2 = "4/1/" & Me.txtYear.Value
TicklerDT3 = "7/1/" & Me.txtYear.Value
TicklerDT4 = "10/1/" & Me.txtYear.Value
Dim sUser As String
Dim sQuarter As Variant
'get the login user name
strUserName = Environ("USERNAME")
sUser = strUserName
' Sets the current record so that after DoCmd.Requery the same record appears
curr_rec = Me.CurrentRecord
Set db = CurrentDb
' Quarter 1 Processing
If ReportDueDT1 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=1) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 1, tblTickler.ReportDueDT = #" & ReportDueDT1 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT1 & "#;"
sQuarter = 1
End If
'Quarter 2 Processing
If ReportDueDT2 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=2) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 2, tblTickler.ReportDueDT = #" & ReportDueDT2 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT2 & "#;"
sQuarter = 2
End If
'Quarter 3 Processing
If ReportDueDT3 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=3) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 3, tblTickler.ReportDueDT = #" & ReportDueDT3 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT3 & "#;"
sQuarter = 3
End If
' Quarter 4 Processing
If ReportDueDT4 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=4) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 4, tblTickler.ReportDueDT = #" & ReportDueDT4 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT4 & "#;"
sQuarter = 4
End If
' Prepare dataset for email processing of records
'Note: this SQL is run for each of the four quarters above _
with only the sQuarter field being replaced each time
strSQL = "SELECT tblTickler.TicklerID, tblTickler.GrantID, tblTickler.TicklerReason, " & _
"tblTickler.TicklerPerson, tblTickler.ReportDueDT, tblTickler.ReportQuarter, " & _
"tblTickler.TicklerDueDT, tblTickler.TicklerSent, tblGrantNameLKU.GrantName, " & _
"tblGrantIdentifierLKU.GrantIdentifier " & _
"FROM (tblGrantNameLKU INNER JOIN (tblGrantIdentifierLKU INNER JOIN tblGrants " & _
"ON tblGrantIdentifierLKU.GrantIdentifierID = tblGrants.GrantIdentifierID) " & _
"ON tblGrantNameLKU.GrantNameID = tblGrants.GrantNameID) INNER JOIN tblTickler " & _
"ON tblGrants.GrantID = tblTickler.GrantID " & _
"WHERE tblTickler.TicklerPerson='" & strUserName & "' AND " & _
"tblTickler.ReportQuarter= " & Replace(sQuarter, "'", "''") & " AND " & _
"tblTickler.TicklerSent=False"
Set rstCurrent = CurrentDb.OpenRecordset(strSQL)
If rstCurrent.RecordCount = 0 Then 'there are no ticklers pending
'release the vaiable
Set rstCurrent = Nothing
Exit Sub
End If
' otherwise move to the last record to get an accurate record count
rstCurrent.MoveLast
rstCurrent.MoveFirst
Dim strSubject As String
Dim strBody As String
'loop through the recordset
Dim j As Integer
For j = 1 To rstCurrent.RecordCount
strSubject = "Reminder on Grant - " & rstCurrent.Fields("GrantName") & "Grant Identifier - " & rstCurrent.Fields("GrantIdentifier")
strBody = "You set a tickler to remind you about this Grant for the following reason: " & rstCurrent.Fields("TicklerReason")
Call SendMessage(sUser, strSubject, strBody)
'set the TicklerSent field to yes so this reminder will not be sent again
rstCurrent.Edit
rstCurrent.Fields("TicklerSent") = vbYes
rstCurrent.Update
rstCurrent.MoveNext
Next j
'release the variable
Set rstCurrent = Nothing
ErrorHandler:
MsgBox "Error #" & Err.Number & " occurred. " & Err.Description, vbOKOnly, "Error"
Exit Sub
End Sub
Private Sub SendMessage(Recipname As String, SubjectText As String, BodyText As String, Optional AttachmentPath As String)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
'Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
'Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Zaranski, Bernard")
objOutlookRecip.Type = olTo
' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Johnston, Kathleen;Fino, Dominic")
objOutlookRecip.Type = olCC
' Set the Subject, Body, and Importance of the message.
.Subject = SubjectText
.Body = BodyText & vbCrLf
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
' If Not IsMissing(AttachmentPath) And AttachmentPath <> vbNullString Then
' Set objOutlookAttach = .Attachments.Add(AttachmentPath)
' End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
'Show the email so it can be edited
.Display
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub
Anyway, as I look at the code I am thinking there might be a better way to do this by using less code. For example, I have four sections of code for each of the four quarters. I was wondering if this could be shortened to one by using variables? As I said, with the help of folks on this site, I managed to accomplish this in the SQL statement that runs to select the records to process through email.
I know this is an odd request, but I am looking for any suggestions or comments as to how the code could be shortened or made more efficient. I believe in code reviews as they tend to make things much better for all involved. Plus, I get to learn from the experts.
Thanks in advance to anyone who decides to read the following code and comment.
Dom
Option Compare Database
Option Explicit
'TicklerDT - date - Date to send reminder
'TicklerReason - memo - Reason to check the record
'TicklerPerson - text - person to send reminder to
'TicklerSent - yes/no - checked when the code issues the reminder.
'Note - need to set a reference to DAO and to your version of Outlook before using the code
Private Sub Form_Load()
'call the routine to check for ticklers that are due
CheckForTicklers
End Sub
Private Sub CheckForTicklers()
'checks to see if the given user is due for a reminder about a particular grant
On Error GoTo ErrorHandler
'create a recordset of all unsent ticklers this user has set
Dim rstCurrent As Recordset
Dim strSQL As String
Dim strSQLtest As String
Dim strUserName As String
Dim db As Database
Dim curr_rec As String
'set tickler dates and report due dates for the current year
Dim yr As Long
yr = Year(Now())
Me.txtYear.Value = Year(Now())
Dim ReportDueDT1 As Date
Dim ReportDueDT2 As Date
Dim ReportDueDT3 As Date
Dim ReportDueDT4 As Date
Dim TicklerDT1 As Date
Dim TicklerDT2 As Date
Dim TicklerDT3 As Date
Dim TicklerDT4 As Date
ReportDueDT1 = "1/15/" & Me.txtYear.Value
ReportDueDT2 = "4/15/" & Me.txtYear.Value
ReportDueDT3 = "7/15/" & Me.txtYear.Value
ReportDueDT4 = "10/15/" & Me.txtYear.Value
TicklerDT1 = "1/1/" & Me.txtYear.Value
TicklerDT2 = "4/1/" & Me.txtYear.Value
TicklerDT3 = "7/1/" & Me.txtYear.Value
TicklerDT4 = "10/1/" & Me.txtYear.Value
Dim sUser As String
Dim sQuarter As Variant
'get the login user name
strUserName = Environ("USERNAME")
sUser = strUserName
' Sets the current record so that after DoCmd.Requery the same record appears
curr_rec = Me.CurrentRecord
Set db = CurrentDb
' Quarter 1 Processing
If ReportDueDT1 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=1) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 1, tblTickler.ReportDueDT = #" & ReportDueDT1 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT1 & "#;"
sQuarter = 1
End If
'Quarter 2 Processing
If ReportDueDT2 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=2) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 2, tblTickler.ReportDueDT = #" & ReportDueDT2 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT2 & "#;"
sQuarter = 2
End If
'Quarter 3 Processing
If ReportDueDT3 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=3) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 3, tblTickler.ReportDueDT = #" & ReportDueDT3 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT3 & "#;"
sQuarter = 3
End If
' Quarter 4 Processing
If ReportDueDT4 >= DateAdd("d", -14, Now()) And GrantID = Me!GrantID Then
strSQLtest = "SELECT Count(tblTickler.TicklerID) AS CountOfTicklerID " & _
"From tblTickler WHERE (((tblTickler.ReportQuarter)=4) " & _
"AND ((tblTickler.TicklerSent)=No));"
If Count = 0 Then 'there are no records to process
Exit Sub
End If
'otherwise there are records to process
CurrentProject.Connection.Execute "UPDATE tblTickler SET " & _
"tblTickler.ReportQuarter = 4, tblTickler.ReportDueDT = #" & ReportDueDT4 & "#, " & _
"tblTickler.TicklerDueDT = #" & TicklerDT4 & "#;"
sQuarter = 4
End If
' Prepare dataset for email processing of records
'Note: this SQL is run for each of the four quarters above _
with only the sQuarter field being replaced each time
strSQL = "SELECT tblTickler.TicklerID, tblTickler.GrantID, tblTickler.TicklerReason, " & _
"tblTickler.TicklerPerson, tblTickler.ReportDueDT, tblTickler.ReportQuarter, " & _
"tblTickler.TicklerDueDT, tblTickler.TicklerSent, tblGrantNameLKU.GrantName, " & _
"tblGrantIdentifierLKU.GrantIdentifier " & _
"FROM (tblGrantNameLKU INNER JOIN (tblGrantIdentifierLKU INNER JOIN tblGrants " & _
"ON tblGrantIdentifierLKU.GrantIdentifierID = tblGrants.GrantIdentifierID) " & _
"ON tblGrantNameLKU.GrantNameID = tblGrants.GrantNameID) INNER JOIN tblTickler " & _
"ON tblGrants.GrantID = tblTickler.GrantID " & _
"WHERE tblTickler.TicklerPerson='" & strUserName & "' AND " & _
"tblTickler.ReportQuarter= " & Replace(sQuarter, "'", "''") & " AND " & _
"tblTickler.TicklerSent=False"
Set rstCurrent = CurrentDb.OpenRecordset(strSQL)
If rstCurrent.RecordCount = 0 Then 'there are no ticklers pending
'release the vaiable
Set rstCurrent = Nothing
Exit Sub
End If
' otherwise move to the last record to get an accurate record count
rstCurrent.MoveLast
rstCurrent.MoveFirst
Dim strSubject As String
Dim strBody As String
'loop through the recordset
Dim j As Integer
For j = 1 To rstCurrent.RecordCount
strSubject = "Reminder on Grant - " & rstCurrent.Fields("GrantName") & "Grant Identifier - " & rstCurrent.Fields("GrantIdentifier")
strBody = "You set a tickler to remind you about this Grant for the following reason: " & rstCurrent.Fields("TicklerReason")
Call SendMessage(sUser, strSubject, strBody)
'set the TicklerSent field to yes so this reminder will not be sent again
rstCurrent.Edit
rstCurrent.Fields("TicklerSent") = vbYes
rstCurrent.Update
rstCurrent.MoveNext
Next j
'release the variable
Set rstCurrent = Nothing
ErrorHandler:
MsgBox "Error #" & Err.Number & " occurred. " & Err.Description, vbOKOnly, "Error"
Exit Sub
End Sub
Private Sub SendMessage(Recipname As String, SubjectText As String, BodyText As String, Optional AttachmentPath As String)
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
'Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItem(olMailItem)
With objOutlookMsg
'Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Zaranski, Bernard")
objOutlookRecip.Type = olTo
' Add the CC recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add("Johnston, Kathleen;Fino, Dominic")
objOutlookRecip.Type = olCC
' Set the Subject, Body, and Importance of the message.
.Subject = SubjectText
.Body = BodyText & vbCrLf
.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
' If Not IsMissing(AttachmentPath) And AttachmentPath <> vbNullString Then
' Set objOutlookAttach = .Attachments.Add(AttachmentPath)
' End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
objOutlookMsg.Display
End If
Next
'Show the email so it can be edited
.Display
End With
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
End Sub