Code:
OptionCompare Database
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Dim i, Numdays, ApptTotalTime, Color As Variant
Dim strDay, strDaysTotal, strSwingsTotal, strMidsTotal AsString
Dim dtDate, dtDateStart, dtDateStop, dtLastShift As Date
Dim blnWDDay As Boolean
Dim strAppt, strAppt1, strAppt2, strAppt3, strAppt4,strAppt5 As String
Dim strLV, strLV1, strLV2, strLV3, strLV4, strLV5 As String
Dim strTDY, strTDY1, strTDY2, strTDY3, strTDY4 As String
Dim strWD, strWD1, strWD2, strWD3, strWD4, strWD5 As String
Dim strShift, strShift1, strShift2, strShift3, strShift4 AsString
Dim qryLV, qryTDY, qryAppt, qryWD, qryShift As QueryDef
Dim rstLV, rstTDY, rstAppt, rstWD, rstShift, rstHoliday AsDAO.Recordset
Dim dbs As Database
Me!Count = Me!Count + 1
Numdays = MonthLength
Set dbs = CurrentDb
dtDateStart = Format(DateSerial([Forms]![ReportsF]![YrSel],[Forms]![ReportsF]![MoSel], 1), "m/d/yyyy")
dtDateStop = Format(DateSerial([Forms]![ReportsF]![YrSel],[Forms]![ReportsF]![MoSel], Numdays), "m/d/yyyy")
'Defines the leave query
strLV1 = "SELECT MPersStatusQ.USERID,MPersStatusQ.PSStart, MPersStatusQ.PSEnd, MPersStatusQ.MStat FROM MPersStatusQWHERE (((MPersStatusQ.USERID)='"
strLV2 = "') AND ((MPersStatusQ.PSStart)<=#"
strLV3 = "#) AND ((MPersStatusQ.PSEnd)>=#"
strLV4 = "#) AND ((MPersStatusQ.MStat)='L'"
strLV5 = ")) ORDER BY MPersStatusQ.PSStart"
strLV = strLV1 & Me!USERID & strLV2 & dtDateStop& strLV3 & dtDateStart & strLV4 & strLV5
Set qryLV = dbs.CreateQueryDef("", strLV)
Set rstLV = qryLV.OpenRecordset
'Defines the TDY query
strTDY1 = "SELECT MMMAQ.USERID, MMMAQ.MStart,MMMAQ.MEnd FROM MMMAQ WHERE (((MMMAQ.USERID)='"
strTDY2 = "') AND ((MMMAQ.MStart)<=#"
strTDY3 = "#) AND ((MMMAQ.MEnd)>=#"
strTDY4 = "#)) ORDER BY MMMAQ.MStart"
strTDY = strTDY1 & Me!USERID & strTDY2 &dtDateStop & strTDY3 & dtDateStart & strTDY4
Set qryTDY = dbs.CreateQueryDef("", strTDY)
Set rstTDY = qryTDY.OpenRecordset
'Defines the Appointment query
strAppt1 = "SELECT MPersStatusQ.USERID,MPersStatusQ.PSStart, MPersStatusQ.PSEnd, MPersStatusQ.Notes, MPersStatusQ.[AllDay Event], MPersStatusQ.MStat FROM MPersStatusQ WHERE(((MPersStatusQ.USERID)='"
strAppt2 = "') AND ((MPersStatusQ.PSStart)<=#"
strAppt3 = "#) AND ((MPersStatusQ.PSEnd)>=#"
strAppt4 = "#) AND ((MPersStatusQ.MStat)='A'"
strAppt5 = "))ORDER BY MStatusQ.PSStart"
strAppt = strAppt1 & Me!USERID & strAppt2 &dtDateStop & strAppt3 & dtDateStart & strAppt4 & strAppt5
Set qryAppt = dbs.CreateQueryDef("", strAppt)
Set rstAppt = qryAppt.OpenRecordset
'Defines the Weekend Duty query
strWD1 = "SELECT MPersShiftTabQ.USERID,MPersShiftTabQ.PSHStart, MPersShiftTab.ShiftEndDt, MPersShiftTab.ShftID FROMMPersShiftTabQ WHERE (((MPersShiftTabQ.USERID)='"
strWD2 = "') AND ((MPersShiftTabQ.PSHStart)<=#"
strWD3 = "#) AND((MPersShiftTabQ.ShiftEndDt)>=#"
strWD4 = "#) AND ((MPersShiftTabQ.ShftID)='W'"
strWD5 = "))ORDER BY MPersShiftTabQ.PSHStart"
strWD = strWD1 & Me!USERID & strWD2 & dtDateStop& strWD3 & dtDateStart & strWD4 & strWD5
Set qryWD = dbs.CreateQueryDef("", strWD)
Set rstWD = qryWD.OpenRecordset
'Defines the Shift query
strShift1 = "SELECT MPersShiftTabQ.USERID,MPersShiftTabQ.PSHStart, MPersShiftTabQ.ShiftSel, MPersShiftTabQ.ShiftID FROMMPersShiftTabQ WHERE (((MPersShiftTabQ.USERID)='"
strShift2 = "') AND((MPersShiftTabQ.PSHStart)<=#"
strShift3 = "#) AND((MPersShiftTabQ.ShiftID)<>'8'"
strShift4 = ")) ORDER BY MPersShiftTabQ.PSHStart"
strShift = strShift1 & Me!USERID & strShift2 &dtDateStop & strShift3 & strShift4 & strShift5
Set qryShift = dbs.CreateQueryDef("", strShift)
Set rstShift = qryShift.OpenRecordset
Set rstHoliday = Holiday(Numdays, dbs) 'Uses the Holidayfunction at the bottom of this page
'Cycles through each day of the month, checking the variousqueries to see if that person is on leave, TDY, etc.
For i = 1 To Numdays
dtDate =DateSerial([Forms]![ReportsF]![YrSel], [Forms]![ReportsF]![MoSel], i)
strDay = "Day" & i
strDaysTotal = "Day" &i & "DaysTotal"
strSwingsTotal = "Day"& i & "SwingsTotal"
strMidsTotal = "Day" &i & "MidsTotal"
Me(strDay) = ""
Me(strDay).ForeColor = 0
Select Case DatePart("w",DateSerial([Forms]![ReportsF]![YrSel], [Forms]![ReportsF]![MoSel], i)) 'Makesthe weekends grey
Case 1, 7'Weekend
Color = 12632256 ' Colors the square Grey for Weekends and Holidays
blnWDDay = True 'Marks them as a weekend
Case Else
Color = 16777215 'Otherwise, the square is White
blnWDDay = False
End Select
With rstHoliday 'Makes the holidaysgrey
If.RecordCount <> 0 Then
.MoveFirst
Do While Not .EOF
If .Fields(0) = dtDate Then
Color = 12632256 'Colors the square Grey
blnWDDay = True 'Marks it as a weekend day
End If
.MoveNext
Loop
.MoveFirst
End If
End With
If blnWDDay Then 'Doesn't countpeople on the weekends or holidays
Me(strDaysTotal) = ""
Me(strSwingsTotal) = ""
Me(strMidsTotal) = ""
End If
Me(strDay).BackColor = Color
With rstLV 'If the person is onleave, marks the day with an L and colors it Light Blue
If.RecordCount <> 0 Then
.MoveFirst
Do While (Not .EOF) And (Me(strDay) <> "L") 'If it's notalready marked with an L
If .Fields(1) <= dtDate And .Fields(2) >= dtDate Then
Me(strDay) = "L"
Me(strDay).BackColor = 16764057 'Colors the square Light Blue
End If
.MoveNext
Loop
.MoveFirst
End If
End With
If Me(strDay) = "" Then'If they aren't on leave
With rstTDY'If they are TDY, marks the day with a T and colors it Light Green
If .RecordCount <> 0 Then
.MoveFirst
Do While (Not .EOF) And (Me(strDay) <> "T") 'If it's notalready marked with a T
If .Fields(1) <= dtDate And .Fields(2) >= dtDate Then
Me(strDay) = "T"
Me(strDay).BackColor = 13434828 'Colors the square Light Green
End If
.MoveNext
Loop
.MoveFirst
End If
End With
End If
If Me(strDay) = "" Then'If they aren't on leave or TDY
With rstAppt'If they have an appointment longer than 1 hour or All Day, marks the day withan A and colors it Pink
If .RecordCount <> 0 Then
ApptTotalTime = 0
.MoveFirst
Do While (Not .EOF) And (Me(strDay) <> "A")
If .Fields(1) <= dtDate And .Fields(2) >= dtDate Then
If .Fields(2) > .Fields(1) Then 'If appt is more than 1 day
Me(strDay) = "A"
Me(strDay).BackColor = 13408767 ' Pink
Else
If .Fields(6) Then 'If All Day is checked on appt form (Appt is all day)
Me(strDay) = "A"
Me(strDay).BackColor = 13408767 'Pink
Else
If (Not IsNull(.Fields(4))) And (Not IsNull(.Fields(3))) Then 'If Start andStop times aren't blank
If ((.Fields(4) - .Fields(3)) * 24) >= 1 Then 'Checks to see if appointmentis longer than 1 hour
Me(strDay) = "A"
Me(strDay).BackColor = 13408767 'Pink
Else
ApptTotalTime = ApptTotalTime + ((.Fields(4) - .Fields(3)) * 24)
End If
End If
End If
End If
End If
.MoveNext
Loop
.MoveFirst
End If
End With
End If
If (Me(strDay) = "") And(blnWDDay) Then 'If it's a weekend or holiday, and they aren't on leave or TDY
With rstWD'If the person has weekend duty, marks the day with a W and colors it Yellow
If .RecordCount <> 0 Then
.MoveFirst
Do While (Not .EOF) And (Me(strDay) <> "W")
If .Fields(1) <= dtDate And .Fields(2) >= dtDate Then
Me(strDay) = "W"
Me(strDay).BackColor = 10092543 'Yellow
End If
.MoveNext
Loop
.MoveFirst
End If
End With
End If
If (Me(strDay) = "") And(blnWDDay = False) Then 'If not on leave, TDY, there's no appointment, and itisn't a weekend or holiday
WithrstShift 'Checks what shift they are on
If .RecordCount <> 0 Then
.MoveFirst
dtLastShift = .Fields(1) 'Start Date
ShiftID = .Fields(2) 'Which shift
Do While (Not .EOF)
If (.Fields(1) > dtLastShift) And (.Fields(1) <= dtDate) Then
ShiftID = .Fields(2)
End If
.MoveNext
Loop
Select Case ShiftID
Case 1 'Days
Me(strDay) = "D"
Me(strDay).ForeColor = 8388608 'Colors the "D" Dark Blue
Me(strDaysTotal) = Me(strDaysTotal) + 1 'Adds one to the number of people onDay Shift for that day
Case 2 'Swings
Me(strDay) = "S"
Me(strDay).ForeColor = 8421376 'Colors the "S" Teal
Me(strSwingsTotal) = Me(strSwingsTotal) + 1 'Adds one to the number of peopleon Swings for that day
Case 3 'Mids
Me(strDay) = "M"
Me(strDay).ForeColor = 128 'Colors the "M" Dark Red
Me(strMidsTotal) = Me(strMidsTotal) + 1 'Adds one to the number of people onMids for that day
Case 4 'Nights (12 hr shift)
Me(strDay) = "N"
Me(strDay).ForeColor = 26367 'Colors the "N" Orange
End Select
.MoveFirst
End If
End With
End If
Next i
rstHoliday.Close
rstShift.Close
qryShift.Close
rstAppt.Close
qryAppt.Close
rstWD.Close
qryWD.Close
rstTDY.Close
qryTDY.Close
rstLV.Close
qryLV.Close
End Sub
Private SubGroupHeader2_Format(Cancel As Integer, FormatCount As Integer)
Dim i, Numdays, Color As Variant
Dim strDay, strDayLabel, strDayDOW As String
Dim strDaysTotal, strSwingsTotal, strMidsTotal As String
Dim dtStartDate, dtStopDate, dtDate As Date
Dim dbs As Database
Dim rstHoliday As DAO.Recordset
Me!Count = 0
Numdays = MonthLength
i = Numdays + 1
Do While i <= 31
strDayLabel = "Day" &i & "Label"
strDayDOW = "Day" & i& "DOW"
strDay = "Day" & i
strDaysTotal = "Day" &i & "DaysTotal"
strSwingsTotal = "Day"& i & "SwingsTotal"
strMidsTotal = "Day" &i & "MidsTotal"
Me(strDayLabel).Visible = False
Me(strDayDOW).Visible = False
Me(strDay).Visible = False
Me(strDaysTotal).Visible = False
Me(strSwingsTotal).Visible = False
Me(strMidsTotal).Visible = False
i = i + 1
Loop
Set dbs = CurrentDb
Set rstHoliday = Holiday(Numdays, dbs)
For i = 1 To Numdays
dtDate =DateSerial([Forms]![ReportsF]![YrSel], [Forms]![ReportsF]![MoSel], i)
strDayLabel = "Day" &i & "Label"
strDayDOW = "Day" & i& "DOW"
strDaysTotal = "Day" &i & "DaysTotal"
strSwingsTotal = "Day"& i & "SwingsTotal"
strMidsTotal = "Day" &i & "MidsTotal"
Me(strDaysTotal) = 0
Me(strSwingsTotal) = 0
Me(strMidsTotal) = 0
Select Case DatePart("w",DateSerial([Forms]![ReportsF]![YrSel], [Forms]![ReportsF]![MoSel], i))
Case 1
Color = 12632256 ' Grey for Weekends and Holidays
Me(strDayDOW) = "Su"
Case 2
Color = 16777215 'White for all other days
Me(strDayDOW) = "M"
Case 3
Color = 16777215
Me(strDayDOW) = "Tu"
Case 4
Color = 16777215
Me(strDayDOW) = "W"
Case 5
Color = 16777215
Me(strDayDOW) = "Th"
Case 6
Color = 16777215
Me(strDayDOW) = "F"
Case 7
Color = 12632256
Me(strDayDOW) = "Sa"
End Select
With rstHoliday
If.RecordCount <> 0 Then
.MoveFirst
Do While Not .EOF
If .Fields(0) = dtDate Then
Color = 12632256 'Grey
End If
.MoveNext
Loop
.MoveFirst
End If
End With
Me(strDayLabel).BackColor = Color
Me(strDayDOW).BackColor = Color
Me(strDaysTotal).BackColor = Color
Me(strSwingsTotal).BackColor = Color
Me(strMidsTotal).BackColor = Color
Next i
rstHoliday.Close
End Sub
FunctionMonthLength()
Select Case Forms!ReportsF!MoSel
Case 1, 3, 5, 7, 8, 10, 12 ' Monthswith 31 Days
MonthLength= 31
Case 4, 6, 9, 11 ' Months with 30Days
MonthLength= 30
Case Else 'February
IfDatePart("m", DateAdd("d", 28,DateSerial(Forms!ReportsF!YrSel, Forms!ReportsF!MoSel, 1))) = 2 Then 'Checksfor leap year
MonthLength = 29
Else: MonthLength = 28
End If
End Select
End Function
FunctionHoliday(Numdays As Variant, dbs As Database) As DAO.Recordset
Dim strHoliday, strHoliday1, strHoliday2, strHoliday3,strHoliday4 As String
Dim dtStartDate, dtStopDate, dtDate As Date
Dim qryHoliday As QueryDef
dtDateStart = Forms!ReportsF!BOMDt
dtDateStop = Forms!ReportsF!EOMDt
strHoliday1 = "SELECT MPersStatusQ.MStat,MPersStatusQ.HolDt FROM MPersStatusQ WHERE (((MPersStatusQ.HolDt) Between#"
strHoliday2 = "# And #"
strHoliday3 = "#) AND ((MPersStatusQ.MStat)='H'"
strHoliday4 = "))ORDER By MPersStatusQ.HolDt"
strHoliday = strHoliday1 & dtDateStart & strHoliday2& dtDateStop & strHoliday3 & strHoliday4
Set qryHoliday = dbs.CreateQueryDef("",strHoliday)
Set Holiday = qryHoliday.OpenRecordset
qryHoliday.Close
End Function
Private Sub Report_NoData(Cancel As Integer)
MsgBox ("There was no one selected to work for theperiod you selected")
DoCmd.CancelEvent
End Sub