Option Compare Database
Option Explicit
Public glblEndDate
Public glblStartDate
Public Function getStreakStart(memID As Long) As Date
Dim currentMonth As Date
Dim numMeetings As Integer
Dim numAttended As Integer
Dim numMakeUps As Integer
Dim creditedMeetings
Dim perfectMonth As Boolean
Dim dtmEndDate As Variant
On Error GoTo getStreakStart_Error
dtmEndDate = getEndDate()
If IsNull(dtmEndDate) Or dtmEndDate = 0 Or Not IsDate(dtmEndDate) Then
dtmEndDate = DateSerial(Year(Date), Month(Date), 1)
End If
currentMonth = DateSerial(Year(dtmEndDate), Month(dtmEndDate), 1)
getStreakStart = currentMonth
perfectMonth = True
Do Until Not (perfectMonth)
perfectMonth = False
numMeetings = getNumberMeetings(currentMonth)
numAttended = getNumberMeetingsAttended(memID, currentMonth)
numMakeUps = getNumberMakeUps(memID, currentMonth)
If numMakeUps > 4 Then
numMakeUps = 4
End If
If numMakeUps + numAttended >= numMeetings Then
perfectMonth = True
getStreakStart = currentMonth
currentMonth = DateSerial(Year(currentMonth), Month(currentMonth) - 1, 1)
End If
Loop
On Error GoTo 0
Exit Function
getStreakStart_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getStreakStart of Module mdlStreak"
End Function
Public Function getNumberMeetings(dtmDate As Date) As Integer
On Error GoTo getNumberMeetings_Error
getNumberMeetings = DLookup("Required", "tblMonths", "MonthYear = " & getSQLDate(dtmDate))
On Error GoTo 0
Exit Function
getNumberMeetings_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getNumberMeetings of Module mdlStreak"
End Function
Public Function getNumberMeetingsAttended(memID As Long, currentMonth As Date) As Integer
Dim monthStart As Date
Dim monthEnd As Date
On Error GoTo getNumberMeetingsAttended_Error
monthStart = getFirstOfMonth(currentMonth)
monthEnd = getEndOfMonth(currentMonth)
getNumberMeetingsAttended = DCount("MemberID", "qryMeetingsAttended", "MeetingDate >= " & getSQLDate(monthStart) & " AND MeetingDate <= " & getSQLDate(monthEnd) & " AND MemberID = " & memID)
On Error GoTo 0
Exit Function
getNumberMeetingsAttended_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getNumberMeetingsAttended of Module mdlStreak"
End Function
Public Function getNumberMakeUps(memID As Long, currentMonth As Date) As Integer
Dim monthStart As Date
Dim monthEnd As Date
On Error GoTo getNumberMakeUps_Error
monthStart = getFirstOfMonth(currentMonth)
monthEnd = getEndOfMonth(currentMonth)
getNumberMakeUps = DCount("MemberID", "qryMakeUps", "MeetingDate >= " & getSQLDate(monthStart) & " AND MeetingDate <= " & getSQLDate(monthEnd) & " AND MemberID = " & memID)
On Error GoTo 0
Exit Function
getNumberMakeUps_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getNumberMakeUps of Module mdlStreak"
End Function
Function getSQLDate(varDate As Variant) As String
'Purpose: Return a delimited string in the date format used natively by JET SQL.
'Argument: A date/time value.
'Note: Returns just the date format if the argument has no time component,
' or a date/time format if it does.
'Author: Allen Browne. allen@allenbrowne.com, June 2006.
If IsDate(varDate) Then
If DateValue(varDate) = varDate Then
getSQLDate = Format$(varDate, "\#mm\/dd\/yyyy\#")
Else
getSQLDate = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#")
End If
End If
End Function
Public Function getFirstOfMonth(dtmDate As Date) As Date
On Error GoTo getFirstOfMonth_Error
getFirstOfMonth = DateSerial(Year(dtmDate), Month(dtmDate), 1)
On Error GoTo 0
Exit Function
getFirstOfMonth_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getFirstOfMonth of Module mdlStreak"
End Function
Public Function getEndOfMonth(dtmDate As Date) As Date
On Error GoTo getEndOfMonth_Error
getEndOfMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
On Error GoTo 0
Exit Function
getEndOfMonth_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getEndOfMonth of Module mdlStreak"
End Function
Public Function getMin(mkups As Variant, mkupsallowed As Variant) As Integer
On Error GoTo getMin_Error
If IsNull(mkups) Then mkups = 0
If mkups > mkupsallowed Then
getMin = mkupsallowed
Else
getMin = mkups
End If
On Error GoTo 0
Exit Function
getMin_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getMin of Module mdlStreak"
End Function
Public Function getEndDate() As Variant
' you can pull this off a form
'getEndDate = forms("yourForm").yourControlname
On Error GoTo getEndDate_Error
getEndDate = Forms("frmPerfectAttendance").txtEndDate
On Error GoTo 0
Exit Function
getEndDate_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getEndDate of Module mdlStreak"
End Function
Public Function getStartDate() As Variant
' you can pull this off a form
'getStartDate = forms("yourForm").yourControlname
'or return a global variable
On Error GoTo getStartDate_Error
getStartDate = CDate(Forms("frmPerfectAttendance").txtStartDate)
On Error GoTo 0
Exit Function
getStartDate_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure getStartDate of Module mdlStreak"
End Function
