Thanks to those who helped me with the Easter dates. I thought I would show my appreciation by sharing the code. If you make any enhancements or comments please post. If anyone is interested just Email me your address and I will send you the project on how I used the classes.
Here's the code for creating statutory holidays class:
The code to the recurring dates class:
Here's the form's module that I implemented the class. The DoCheck function just checks that all the appropriate text boxes are filled etc. There are seven checkboxes, one for each day and the tag property is set to correspond to the vbConstant that each day represents:
Hope this helps,
Rewdee
Here's the code for creating statutory holidays class:
Code:
''''''''''''''''''''''''''''''''''''
Statutory Holiday Class
Created by William D. Nielsen
[URL unfurl="true"]www.2Rs.ca[/URL]
Date: September 11,2002
Description: This class basic function is to calculate and manage statutory holidays
Client: YMCA of Woodbuffalo
''''''''''''''''''''''''''''''''''''''''''
Option Compare Database
'error handling constants
Private Const cERR_ADD_DATE As Long = 3001
Private Const cERR_ADD_MSG As String = "Error in attempting to add the date: "
'private fields
Private mdteStart As Date
Private mdteEnd As Date
Private mcolStatHolidays As Collection
'Initialize the class and set variables to default values
Private Sub Class_Initialize()
Set mcolStatHolidays = New Collection
mdteStart = Date
mdteEnd = DateSerial(Year(dteStart), 12, 31) 'default to last day of the current year
End Sub
'Free class and instance of statutory holidays
Private Sub Class_Terminate()
Set mcolStartHolidays = Nothing
End Sub
Property Let StartDate(ByVal dte As Date)
mdteStart = dte
'force recalculation
getStatHolidays
End Property
Property Get StartDate() As Date
StartDate = mdteStart
End Property
Property Let EndDate(ByVal dte As Date)
mdteEnd = dte
'force recalculation
getStatHolidays
End Property
Property Get EndDate() As Date
EndDate = mdteEnd
End Property
Public Function StatHolidays() As Collection
Set StatHolidays = mcolStatHolidays
End Function
Public Sub AddStatHoliday(dte As Date)
'simple adding to the holiday collection
On Error GoTo errHandler
mcolStatHolidays.Add dte, CStr(dte)
Exit Sub
errHandler:
Select Case Err.number
Case 457: 'just ignore if it is a duplicate entry
Exit Sub
Case Else
Err.Raise cERR_ADD_DATE, Err.Source,
cERR_ADD_MSG & CStr(dte)
End Select
End Sub
Public Sub RemoveStatHoliday(dte As Date)
On Error Resume Next
mcolStatHolidays.Remove dte
End Sub
Public Sub AddVariableStatHoliday(iMonth As Integer, iWeek
As Integer, iDay As Integer)
'''''''''''''''''''''''''''''''''''''''
'IN:
'
' iMonth : represents the Month e.g. 1-January,2-
February, etc. '
' iWeek : represents what week of the month e.g. 3-third
week '
' iDay : represents the weekday of the 1-Sunday,2-
Monday, etc '
'An Example would be the Canadian Holdiay Victoria day
which is '
'the third Monday of each May and hence the call to this
procedure'
'would
be: '
' AddVariableStatHoliday
5,3,1 '
''''''''''''''''''''''''''''''''''''''''''''
********************************************
'*PROGRAMMER'S NOTE: There is no error checking to ensure
that *
'* that what is passed to this procedure
is *
'* invalid. Disaster may come upon
the *
'* programmer who uses this without
either *
'* writing a more stringent data
checking *
'* here or on the front end as
dateserial *
'* will always return a valid
date. *
'* ******************************************
'some holidays like labour day, Victoria Day, etc. do not
have a fixed date and hence this function to
'calculate and add to collection of statutory holidays
Dim iWkday As Integer
Dim iStatDay As Integer
Dim iCount As Integer
Dim dteStat As Date
On Error GoTo errHandler
'get the first day of the particular month
iWkday = Weekday(DateSerial(Year(mdteStart), iMonth, 1))
'find what day it is
'check if it is the correct date
If iWkday = iDay Then
iStatDay = iWkday + ((iWeek - 1) * 7)
Else
'loop through the days of the week until reached
the parameter day
iCount = 1
Do
iCount = iCount + 1
Loop Until iDay = Weekday(DateSerial(Year
(mdteStart), iMonth, iCount))
iStatDay = iCount + ((iWeek - 1) * 7)
End If
'add the holiday to the collection
dteStat = DateSerial(Year(mdteStart), iMonth, iStatDay)
'check if we need to see if next year
mcolStatHolidays.Add dteStat, CStr(dteStat)
If Year(mdteEnd) > Year(mdteStart) Then
mcolStatHolidays.Add DateSerial(Year(mdteEnd),
iMonth, iStatDay), CStr(DateSerial(Year(mdteEnd), iMonth,
iStatDay))
End If
Exit Sub
errHandler:
Select Case Err.number
Case 457: 'just ignore if it is a duplicate entry
Exit Sub
Case Else
Err.Raise cERR_ADD_DATE, Err.Source, cERR_ADD_MSG & CStr(dteStat)
End Select
End Sub
Private Sub getStatHolidays()
**********************************************************
'*PROGRAMMER'S NOTE: It would be more efficient to check
whether a date is already present and *
'* add/delete dates depending on my
mdteStart and mdeteEnd date ranges but *
'* but for simplicity sake I just delete
everything and start over. *
********************************************************
Dim iCount As Integer
Dim dteArr(8) As Date
Dim dteEaster As Date
Dim dteGoodFr As Date
'clear the previous holidays in my collection
For iCount = 1 To mcolStatHolidays.Count
mcolStatHolidays.Remove 1
Next
'add common date type holidays
dteArr(0) = DateSerial(Year(mdteStart), 1, 1) 'New
Year's day
dteArr(1) = DateSerial(Year(mdteStart), 7,
1) 'Canada Day
dteArr(2) = DateSerial(Year(mdteStart), 12,
25) 'Christmas
dteArr(3) = DateSerial(Year(mdteStart), 12,
26) 'Boxing Day
'now add dates to see if we need to add dates for the
following year
'this will occur when the dteStart is in one year and
dteFinish is
'in the following year e.g. December 1, 2002 and
Febuary 14, 2003
**********************************************************
'*PROGRAMMER'S NOTE: For my purposes the mdteStart and
mdteEnd time frame will not be greater *
'* than one year. For time frames
greater than one year a dynamic array will *
'* have to be
used. *
***********************************************************
dteArr(4) = DateSerial(Year(mdteStart) + 1, 1,
1) 'New Year's day
dteArr(5) = DateSerial(Year(mdteStart) + 1, 7,
1) 'Canada Day
dteArr(6) = DateSerial(Year(mdteStart) + 1, 12,
25) 'Christmas
dteArr(7) = DateSerial(Year(mdteStart) + 1, 12,
26) 'Boxing Day
'now iterate through the holidays seeing if the dates
are within the specified
For iCount = 0 To UBound(dteArr)
If dteArr(i) >= mdteStart And dteArr(i) <= mdteEnd Then mcolStatHolidays.Add dteArr(i), dteArr(i)
Next iCount
'now check to see if the Easter holidays need to be
added
dteEaster = EasterDate(Year(mdteStart))
dteGoodFr = DateAdd("d", -2, dteEaster)
If dteEaster >= mdteStart And dteEaster <= mdteEnd Then
mcolStatHolidays.Add dteEaster, CStr(dteEaster)
If dteGoodFr >= mdteStart And dteGoodFr <= mdteEnd Then
mcolStatHolidays.Add dteGoodFr, CStr(dteGoodFr)
'if the EndDate goes to the next year--check to add
those Easter Dates
If Year(dteEnd) > Year(dteStart) Then
dteEaster = EasterDate(Year(mdteEnd))
dteGoodFr = DateAdd("d", -2, dteEaster)
If dteEaster >= mdteStart And dteEaster <= mdteEnd
Then mcolStatHolidays.Add dteEaster, CStr(dteEaster)
If dteGoodFr >= mdteStart And dteGoodFr <= mdteEnd
Then mcolStatHolidays.Add dteGoodFr, CStr(dteGoodFr)
End If
End Sub
Public Function EasterDate(YearToCalculate As Integer) As
Date
'taken from
[URL unfurl="true"]http://www.blibbleblobble.co.uk/Downloads/CodeLibrary/Functi[/URL]
ons/EasterDate.htm
Dim CurrentCentury As Integer
Dim YearMod19 As Integer
Dim Temp As Variant
Dim tA As Integer
Dim tB As Integer
Dim tC As Integer
Dim Temp2 As Variant
Dim tD As Integer
Dim tE As Integer
Dim EasterDayOfMonth As Integer
'Store the number of the current century
CurrentCentury = Int(YearToCalculate / 100)
'Determine the approximate place in the 19-year solunar
cycle
YearMod19 = Int(Remainder(YearToCalculate, 19))
'calculate PFM date
Temp = Int((CurrentCentury - 15) / 2) + 202 - (11 *
YearMod19)
'Insert leap days to fiddle the solunar cycle to make
it 19 years
If (CurrentCentury > 26) Then
Temp = -1
End If
Select Case CurrentCentury
Case 21, 24, 25:
Temp = -1
Case Else:
End Select
Temp = Remainder(Temp, 30)
tA = Temp + 21
If Temp = 29 Then
tA = tA - 1
End If
If (Temp = 28) And (YearMod19 > 10) Then
tA = tA - 1
End If
'find the next Sunday
tB = Remainder((tA - 19), 7)
'fix the leap years in 1 of every 4 ceuturies
tC = Remainder((40 - CurrentCentury), 4)
If tC = 3 Then
tC = tC + 1
End If
If tC > 1 Then
tC = tC + 1
End If
Temp = Remainder(YearToCalculate, 100)
Temp2 = CStr(Temp / 4)
If Mid(Temp2, 1, 1) = "." Then
Temp2 = "0" & Temp2
End If
Temp2 = Int(Temp2)
'Find the next sunday
tD = Remainder((Temp + Temp2), 7)
tE = Remainder((20 - tB - tC - tD), 7) + 1
'Calculate the number of days since the beginning of
march
EasterDayOfMonth = tA + tE
'Convert to a VB date format
EasterDate = CDate("1 march " & CStr(YearToCalculate))
+ EasterDayOfMonth - 1
End Function
Private Function Remainder(VarNumerator As Variant,
varDivisor As Variant) As Integer
Remainder = VarNumerator Mod varDivisor
End FunctionThe code to the recurring dates class:
Code:
'''''''''''''''''''''''''''''''''''''''''''''''
clsRecurrDates Class
Created by William D. Neilsen
[URL unfurl="true"]www.2rs.ca[/URL]
Date: September 11, 2002
Description: This class will initiate an object that will have the properties and methods to create a list of recurring dates and holiday conflicts between dates
Client : YMCA of WoodBuffalo
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Compare Database
Private mobjHolidays As clsStatHolidays 'object of
clsStatHolidays to watch for conflicting days
Private mdteStart As Date 'start point to
check for appointments
Private mdteEnd As Date 'end point to
check for appointements
Private mbInclHol As Boolean 'whether to
make an appointment on a holiday
Private mintNumOfRec As Integer 'Number of
appointments that could be made
Private mcolApptDays As Collection 'Days that
appointments are on eg. every Tuesday and Wednesday
Private mcolRecDates As Collection 'collection of
appointments that could be made
Private mcolHolConf As Collection 'collection of
appointments that could not be made due to holiday conflicts
Private bDoneFlag As Boolean 'variable keeps
track whether need to recalculate again
'Initialize the class and set variables to default values
Private Sub Class_Initialize()
On Local Error GoTo Class_Initialize_Err
Dim Msg As String
mdteStart = Date
mdteEnd = DateSerial(Year(Date), 12, 31)
mbInclHol = False
mintNumOfRec = 0
Set mcolApptDays = New Collection
Set mcolRecDates = New Collection
Set mcolHolConf = New Collection
Set mobjHolidays = New clsStatHolidays
mobjHolidays.StartDate = mdteStart
mobjHolidays.EndDate = mdteEnd
bDoneFlag = False
Class_Initialize_End:
Exit Sub
Class_Initialize_Err:
Msg = "Error #: " & Format$(Err.number) & vbCrLf
Msg = Msg & Err.Description
Err.Raise vbObjectError, "Cannot Create Appointment Recurring Object", Msg
Resume Class_Initialize_End
End Sub
'Free class and instance of Textfile
Private Sub Class_Terminate()
On Error Resume Next
Set mcolApptDays = Nothing
Set mcolRecDates = Nothing
Set mcolHolConf = Nothing
Set mobjHolidays = Nothing
End Sub
Property Let StartDate(ByVal dte As Date)
mdteStart = dte
mobjHolidays.StartDate = dte
'every time this variable is reset signal needs recalc
bDoneFlag = False
End Property
Property Get StartDate() As Date
StartDate = mdteStart
End Property
Property Let EndDate(ByVal dte As Date)
mdteEnd = dte
mobjHolidays.EndDate = dte
'every time this variable is reset signal needs recalc
bDoneFlag = False
End Property
Property Get EndDate() As Date
EndDate = mdteEnd
End Property
Property Let IncludeHolidays(ByVal b As Boolean)
mbInclHol = b
End Property
Property Get IncludeHolidays() As Boolean
IncludeHolidays = mbInclHol
End Property
Property Get NumberOfApptments() As Integer
NumberOfApptments = mintNumOfRec
End Property
Property Get ApptDays() As Collection
Set ApptDays = mcolApptDays
End Property
Public Sub AddADate(iDay As Integer)
On Error Resume Next
mcolApptDays.Add iDay, CStr(iDay)
End Sub
Public Sub RemoveADate(iDay As Integer)
On Error Resume Next
mcolApptDays.Remove CStr(iDay)
End Sub
Public Sub AddStatHoliday(dte As Date)
mobjHolidays.AddStatHoliday (dte)
End Sub
Public Sub AddVariableDateHoliday(iMonth As Integer, iWk As
Integer, iDay As Integer)
mobjHolidays.AddVariableStatHoliday iMonth, iWk, iDay
End Sub
Public Function getRecurringAppts() As Collection
'''''''
If Not bDoneFlag Then DoAppments
Set getRecurringAppts = mcolRecDates
End Function
Public Function getHolidayConflicts() As Collection
'''''''
If Not bDoneFlag Then DoAppments
Set getHolidayConflicts = mcolHolConf
End Function
Private Sub DoAppments()
'''the meat of the class is here'''
Dim iCount As Integer
Dim iMonth As Integer
Dim iDay As Integer
Dim iYear As Integer
Dim dteStartFrom As Date
'iterate through the days collection
For iCount = 1 To mcolApptDays.Count
'get the first start date for this particular date
iMonth = month(mdteStart): iDay = Day(mdteStart): iYear = Year(mdteStart)
Do
dteStartFrom = DateSerial(iYear, iMonth, iDay)
iDay = iDay + 1
Loop Until mcolApptDays.Item(iCount) = Weekday
(dteStartFrom)
'now keep adding weeks until greater than end date
Do While dteStartFrom <= mdteEnd
If IsHoliday(dteStartFrom) And Not mbInclHol
Then
mcolHolConf.Add dteStartFrom, CStr
(dteStartFrom)
Else
mcolRecDates.Add dteStartFrom, CStr
(dteStartFrom)
mintNumOfRec = mintNumOfRec + 1
End If
'reset new start date
dteStartFrom = DateAdd("ww", 1, dteStartFrom)
Loop
Next iCount
'done the calcs for these parameters
bDoneFlag = True
End Sub
Private Function IsHoliday(dte As Date) As Boolean
'simple iteration looling to see if the date passed is in
the holiday collection
Dim iCount As Integer
Dim colHolidays As Collection
Set colHolidays = mobjHolidays.StatHolidays
IsHoliday = False
For iCount = 1 To colHolidays.Count
If Int(dte) = Int(colHolidays.Item(iCount)) Then IsHoliday = True
Next iCount
Set colHolidays = Nothing
End FunctionHere's the form's module that I implemented the class. The DoCheck function just checks that all the appropriate text boxes are filled etc. There are seven checkboxes, one for each day and the tag property is set to correspond to the vbConstant that each day represents:
Code:
Private Sub CmdRecur_Click()
Dim objRecurrences As New clsRecurrDates
Dim colRecAppts As New Collection
Dim ctl As Control
Dim iCount As Integer
Dim sMsg As String
If doCheck Then
With objRecurrences
.StartDate = Me.Date_Start
.EndDate = Me.Date_Finish
.AddVariableDateHoliday 5, 3,
vbMonday 'Victoria Day
.AddVariableDateHoliday 8, 1,
vbMonday 'Civic Holiday for Alberta
.AddVariableDateHoliday 9, 1,
vbMonday 'Canadian Labour Day
For Each ctl In Me
If IsNumeric(ctl.Tag) Then
If ctl.Value Then .AddADate CInt
(ctl.Tag)
End If
Next ctl
If .getRecurringAppts.Count > 0 Then
Set colRecAppts = .getRecurringAppts
sMsg = "The Following Appointment were
added:" & vbCrLf
For iCount = 1 To colRecAppts.Count
sMsg = sMsg & colRecAppts.Item(iCount)
& vbCrLf
Next iCount
End If
If .getHolidayConflicts.Count > 0 Then
sMsg = sMsg & vbCrLf & "The following
Appointments were not made:" & vbCrLf
For iCount = 1 To .getHolidayConflicts.Count
sMsg = sMsg & .getHolidayConflicts.Item
(iCount) & vbCrLf
Next iCount
End If
End With
MsgBox sMsg, vbInformation
End If
End SubHope this helps,
Rewdee
Code:
