Option Compare Database
Option Explicit
' represents keyed values for records
Private Type RecordKey
Sat As Long
S As String
End Type
' *************************************************
' Reworking this 7/20/09 - Phil
' This checks to see that the ODBC connection is ok.
' *************************************************
Function AutoExec()
Forms!frm_Start.lblStatus.Caption = "Adjusting Max Locks Setting"
DAO.DBEngine.SetOption dbMaxLocksPerFile, 25000
Forms!frm_Start.lblStatus.Caption = "Checking ODBC Connectivity"
On Error GoTo Err_AutoExec
Dim rst As Recordset
Dim db As Database
Set db = CurrentDb
Set rst = _
db.OpenRecordset("dbo_Pipe_All", dbOpenDynaset)
' as long as you don't get an ODBC error
' (ie: as long as you can open a full table...)
If (Not (rst.BOF)) Then
' *************************************************
' If you get no errors, proceed to "emailEnginners
' *************************************************
Forms!frm_Start.lblStatus.Caption = "ODBC Connectivity is good. Starting 'Email The Engineers' Application"
Call emailEngineers
Else
Forms!frm_Start.lblStatus.Caption = "ODBC Test has failed"
MsgBox "Caught in AutoExec routine:" & vbCrLf & _
"There's been a problem opening the dbo tables."
End If
rst.Close
db.Close
Exit_AutoExec:
Exit Function
Err_AutoExec:
MsgBox Err.Description
Resume Exit_AutoExec
End Function
' This subroutine is designed to send off a report of problem spots
' that are present in each district to the appropriate
' engineer/manager via email once a week.
Private Sub emailEngineers()
On Error GoTo Err_emailEngineers
' dynamic array used to hold primary key values from tblListOfProblemSpots
Dim aKey() As RecordKey
' variable to hold the current database
Dim db As Database
' Date checking variables for checking the day of the week
Dim dtm As Date
' holds the date of the most recent monday (usually today)
Dim dtmThisOrLastMonday As Date
' variable to hold the difference between today's date and that of the previous monday
Dim iDayDifference As Integer
' used to determine day of the week
Dim iWeekDay As Integer
' loop control variable
Dim i As Integer
' counter variable
Dim iCount As Integer
' name of the report to be sent by email
Dim stDocName As String
' used for email address
Dim stEmailRecipient As String
' used for CC email address
Dim stEmailCC As String
' used for BCC email address
Dim stEmailBCC As String
' used for the text for the email's Subject Line
Dim stSubject As String
' used for the message text for the email
Dim stMessage As String
' used for the regions
Dim stRegion As String
' used to store Engineer/Manager names
Dim stName As String
' used to check if the report to be sent will be empty or not
Dim stQuery As String
' for SQL statements
Dim strSQL As String
' Note that with the following recordsets, only one is used per datasheet
' opened, keeping the code as self-documenting as possible
' used to access the table which holds the most recent date on which the reports were last sent out
Dim rstDateRecord As Recordset
' used to hold the list of problem pipes to be sent to the engineers
Dim rstTroubleSpots As Recordset
' used to access the query which the report will be based on
Dim rstTheReport As Recordset
' used to access names and email addresses in the engineersEmailAddress table
Dim rstNextEngineer As Recordset
' used to access names and email addresses in the tblManagementsEmailAddresses table
Dim rstNextManager As Recordset
' used to hold a list of pipes that are no longer a problem
Dim rstAmelioratedSpots As Recordset
' used to hold a list of pipes that have recently been deleted from the dbo_SFTIO table
Dim rstFixedSpots As Recordset
DoCmd.Hourglass True
' set variables:
iCount = 0
Set db = CurrentDb
dtm = Date
iWeekDay = WeekDay(Date)
iDayDifference = iWeekDay - 2
' if it's sunday:
If (iDayDifference = -1) Then
iDayDifference = 6
End If
dtmThisOrLastMonday = dtm - iDayDifference
'This table holds only the date, which changes from week to week.
Set rstDateRecord = _
db.OpenRecordset("tblDateReportLastSent", dbOpenDynaset)
' First make sure the program only runs once,
' on or after monday each week, and make
' sure we're not still on the same monday...
' (Note: if dtmThisOrLastMonday = rstDateRecord!DateLastChecked
' then we are checking on the same monday or in the
' same week...)
If (dtmThisOrLastMonday > rstDateRecord!DateLastChecked) Then
If ((MsgBox("Run Code?", vbYesNo, "Check your tables first...")) _
= vbYes) Then
Forms!frm_Start.lblStatus.Caption = "Setting the date sent record to today"
' Update the date since we're sending out another report today:
With rstDateRecord
.Edit
!DateLastChecked = Date
.Update
End With 'rstDateRecord
' Add any new problems to our list of problem spots:
' (Note here that the primary key inhibits any duplicate
' values from being created; any additional records
' will be appended to the tblListOfProblemSpots table.)
' **********************************************************************************************
' db.Execute ("qryListOfProblemSpots") 'currently: only TIOS_ID >=AP*
' db.Execute ("qryListOfAdditionalProblemSpots") 'currently: only >=AP*
' removed and changed to DoCmd.OpenQuery 7/20/09 - Phil
'************************************************************************************************
Forms!frm_Start.lblStatus.Caption = "Running qryListofProblemSpots: Adding obs of level 4 and 5"
' this query adds observations that have a level of 4 or 5
DoCmd.SetWarnings False
DoCmd.OpenQuery "qryListOfProblemSpots"
Forms!frm_Start.lblStatus.Caption = "Running qryListofAdditionalProblemSpots: Adding obs of specific codes and thresh-holds"
' This query adds observations that have a specific severity value for specific codes
DoCmd.OpenQuery "qryListOfAdditionalProblemSpots"
DoCmd.SetWarnings True
' Get the list of problem spots and increment the
' counter that keeps track of how many weeks each
' pipe has remained in the table:
Forms!frm_Start.lblStatus.Caption = "Adjusting Max Locks Setting"
DAO.DBEngine.SetOption dbMaxLocksPerFile, 25000
Forms!frm_Start.lblStatus.Caption = "Updating the Times Emailed adding 1 to the previous count"
DAO.DBEngine.SetOption dbMaxLocksPerFile, 25000
Set rstTroubleSpots = _
db.OpenRecordset("tblListOfProblemSpots", dbOpenDynaset)
With rstTroubleSpots
Do While Not .EOF
.Edit
!TimesMailed = (!TimesMailed + 1)
.Update
.MoveNext
Loop 'till not .EOF
End With 'rstTroubleSpots
rstTroubleSpots.Close
Forms!frm_Start.lblStatus.Caption = "The email count has been updated."
Forms!frm_Start.lblStatus.Caption = "Emailing each engineer their report"
' Now email each of the Engineers their reports:
stSubject = "CCTV Problem Spots"
stMessage = "Here is a list of problem spots in your region"
' For each engineer...
Set rstNextEngineer = _
db.OpenRecordset("EngineersEmailAddress", dbOpenDynaset)
With rstNextEngineer
If (Not (.EOF)) Then
.MoveLast
iCount = .RecordCount
.MoveFirst
For i = 1 To iCount
'...get their email address and name...
rstNextEngineer.Edit
stName = rstNextEngineer!Engineer
stEmailRecipient = rstNextEngineer!emailAddress
Forms!frm_Start.lblStatus.Caption = "Sending Email to: " & stEmailRecipient
stEmailCC = rstNextEngineer!cc
stRegion = rstNextEngineer!Region
' ...then get their report...
stDocName = "rpt_" & stRegion
' ...determine whether the report is empty or not...
stQuery = "qry_" & stRegion
Set rstTheReport = _
db.OpenRecordset(stQuery, dbOpenDynaset)
With rstTheReport
If .EOF Then
' ...if so, prepare to send out a
' generic empty report...
stDocName = "rptNoProblems"
End If '.EOF
End With 'rstTheReport
rstTheReport.Close
' ...and email off the report:
'DoCmd.SendObject acSendReport, stDocName, acFormatHTML, _
'stEmailRecipient, , , stMessage, stMessage, False
If stEmailCC <> "" Then
DoCmd.SendObject acReport, stDocName, "SnapshotFormat(*.snp)", _
stEmailRecipient, stEmailCC, , stMessage, stMessage, False
Else
DoCmd.SendObject acReport, stDocName, "SnapshotFormat(*.snp)", _
stEmailRecipient, , , stMessage, stMessage, False
End If
DoCmd.Hourglass True
rstNextEngineer.Update
rstNextEngineer.MoveNext
Next i 'from 1 to icount
End If
End With
rstNextEngineer.Close
Forms!frm_Start.lblStatus.Caption = "Emailing the managers their reports"
' Finally, email each of the managers the complete set:
stMessage = "Here is a list of problem spots found throughout the Districts"
' Determine whether the report is empty or not...
stQuery = "qry_Management"
Set rstTheReport = _
db.OpenRecordset(stQuery, dbOpenDynaset)
If rstTheReport.EOF Then
' ...if so, prepare to send out a
' generic empty report:
stDocName = "rptNoProblem"
Else ' if not .EOF...
' ...then get the manager's report:
stDocName = "rpt_Management"
End If '...EOF
rstTheReport.Close
' For each manager...
Set rstNextManager = _
db.OpenRecordset _
("tblManagementsEmailAddresses", dbOpenDynaset)
With rstNextManager
If (Not (.EOF)) Then
.MoveLast
iCount = .RecordCount
.MoveFirst
For i = 1 To iCount
With rstNextManager
'...get their email address and name...
.Edit
stName = !Engineer
stEmailRecipient = !emailAddress
stEmailBCC = !BCC
Forms!frm_Start.lblStatus.Caption = "Sending Email to:" & !emailAddress
If stEmailBCC <> "" Then
DoCmd.SendObject acReport, stDocName, "SnapshotFormat(*.snp)", _
stEmailRecipient, , stEmailBCC, (stMessage), stMessage, False
Else
DoCmd.SendObject acReport, stDocName, "SnapshotFormat(*.snp)", _
stEmailRecipient, , , (stMessage), stMessage, False
End If
DoCmd.Hourglass True
.Update
.MoveNext
End With '...rstNextManager
Next i 'from 1 to iCount
End If
End With
rstNextManager.Close
Else
MsgBox "Email code aborted"
End If '...run code = yes
End If '...its a new monday
' ...clean up...
RefreshDatabaseWindow
rstDateRecord.Close
db.Close
' ...ok, we're done.
DoCmd.Hourglass False
Exit_emailEngineers:
Exit Sub
Err_emailEngineers:
MsgBox Err.Number & " " & Err.Description
Resume Exit_emailEngineers
End Sub