Microsoft Outlook provides a nice calendar program that allows people to track events. The Outlook, like all other components in the Microsoft Office suite, also provides program interfaces (API) for programmer to extend their use of the program.
In our office, we try to pull these info into our databases. For normal events, the code is straightforward since it is stored in a day by day basis. For recurring events, however, in practical, it can't be stored in a day by day basis since some recurring events don't have an end day. This, therefore, presents a challenge when try to pull in calendar events on a day by day basis. Basically, the program need to go through each recurring event and, based on the pattern of each recurring event, generates the day and time of each occurrences and find out if any of the occurrences fall inside the specific time period of interest.
Below are codes that I devised and I hope it is of value to someone - please provide adequate credit statement if you do adopt and find the code useful.
Few words about the program:
- xCDO is an object that provides access to database.
- PrmtrTyp, Prmtr are just for me to extend code in the future. 1 and "" are normally used.
- BgnDt, and EndDt specify the period of interest.
- xAppntmnt is the Appointment object of Outlook.
- xHC is simply my version of the VBA collection object. It allows to set entries via StItm() function and retrieve value via RdItm() function.
- The handling of yearly recurring events is to be amended.
Public Function DoRecrrngs(aCDO, BgnDt, EndDt, aAppntmnts, Ppl, PrmtrTyp, Prmtr)
Dim status, oAppntmnt, oPttrn
Dim oHC As New HCllctn
For Each oAppntmnt In aAppntmnts
Set oPttrn = oAppntmnt.GetRecurrencePattern
If oPttrn.PatternEndDate >= BgnDt Then
status = oHC.StItm("BgnDt", BgnDt)
status = oHC.StItm("EndDt", EndDt)
status = oHC.StItm("IsAllDy", oAppntmnt.AllDayEvent)
status = oHC.StItm("EvntTtl", oAppntmnt.Subject)
status = oHC.StItm("EvntDtl", oAppntmnt.Location)
status = oHC.StItm("Ppl", Ppl)
status = DoRecrrng(aCDO, oHC, oPttrn, PrmtrTyp, Prmtr)
End If
Next
End Function
Public Function DoRecrrng(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Dim status
Select Case aPttrn.RecurrenceType
Case 0 ' Daily
status = DoRecrrng0_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Case 1 ' Weekly
status = DoRecrrng1_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
' status = -1111
Case 2 ' Monthly (Day of Month)
status = DoRecrrng2_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
' status = -1121
Case 3 ' MonthNth (weekday of Nth week)
status = DoRecrrng3_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
' status = -1131
Case 4 ' ??
status = -1141
Case 5 ' Yearly (Day of Month)
status = -1151
Case 6 ' YearNth (Day of Nth week of Month)
status = -1161
End Select
DoRecrrng = status
End Function
' Daily - assuming aPttrn.PatternEndDate >= BgnDt
Public Function DoRecrrng0_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Dim status, tmpDt, tmpNo, NDay
Dim BgnDt, EndDt, IsAllDy, StrtTm, EndTm, Ppl, EvntTtl, EvntDtl
' Retrieve useful info to local
BgnDt = aHC.RdItm("BgnDt"): EndDt = aHC.RdItm("EndDt")
IsAllDy = aHC.RdItm("IsAllDy"): Ppl = aHC.RdItm("Ppl")
StrtTm = aPttrn.StartTime: EndTm = aPttrn.EndTime
EvntTtl = strRplc("""", "", aHC.RdItm("EvntTtl")): EvntDtl = strRplc("""", "", aHC.RdItm("EvntDtl"))
NDay = aPttrn.Interval ' Every N day
tmpDt = aPttrn.PatternStartDate
If tmpDt < BgnDt Then
tmpNo = DateDiff("d", tmpDt, BgnDt)
tmpNo = tmpNo + NDay - (tmpNo Mod NDay)
tmpDt = DateAdd("d", tmpNo, tmpDt)
End If
DoRecrrng0_ = 0
Do
If tmpDt <= EndDt Then
DoRecrrng0_ = DoRecrrng0_ + 1
' save the event to db
status = Add2EvntTmp(aCDO, IsAllDy, tmpDt + StrtTm, tmpDt + EndTm, _
Ppl, EvntTtl, EvntDtl)
tmpDt = DateAdd("d", NDay, tmpDt)
End If
Loop Until tmpDt > EndDt
End Function
' Weekly - assuming aPttrn.PatternEndDate > BgnDt
Public Function DoRecrrng1_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Dim status, tmpNo, tmpDt, NWk, WkDyBt, WkDyMsk
Dim BgnDt, EndDt, IsAllDy, StrtTm, EndTm, Ppl, EvntTtl, EvntDtl
' Retrieve useful info to local
BgnDt = aHC.RdItm("BgnDt"): EndDt = aHC.RdItm("EndDt")
IsAllDy = aHC.RdItm("IsAllDy"): Ppl = aHC.RdItm("Ppl")
StrtTm = aPttrn.StartTime: EndTm = aPttrn.EndTime
EvntTtl = strRplc("""", "", aHC.RdItm("EvntTtl")): EvntDtl = strRplc("""", "", aHC.RdItm("EvntDtl"))
NWk = aPttrn.Interval ' Every N week
If NWk = 0 Then NWk = 1 ' Adjust Outlook daily weekday assigned value
' Prepare for begin date
tmpDt = aPttrn.PatternStartDate
If tmpDt < BgnDt Then
tmpNo = DateDiff("ww", tmpDt, BgnDt)
tmpNo = tmpNo + NWk - (tmpNo Mod NWk)
tmpDt = DateAdd("ww", tmpNo, tmpDt)
tmpDt = DateAdd("d", 1 - DatePart("w", tmpDt), tmpDt) ' Adjusted to Sunday
End If
' Prepare weekday detection
WkDyBt = 2 ^ (DatePart("w", tmpDt) - 1)
WkDyMsk = aPttrn.DayOfWeekMask
DoRecrrng1_ = 0
Do Until tmpDt > EndDt
If WkDyBt And WkDyMsk Then
' save the event to db
status = Add2EvntTmp(aCDO, IsAllDy, tmpDt + StrtTm, tmpDt + EndTm, _
Ppl, EvntTtl, EvntDtl)
End If
If WkDyBt = 64 Then
tmpDt = DateAdd("ww", NWk, tmpDt)
tmpDt = DateAdd("d", 1 - DatePart("w", tmpDt), tmpDt) ' Adjusted to Sunday
WkDyBt = 1
Else
tmpDt = DateAdd("d", 1, tmpDt)
WkDyBt = WkDyBt * 2
End If
Loop
End Function
' Monthly (day of month) - assuming aPttrn.PatternEndDate > BgnDt
Public Function DoRecrrng2_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Dim status, tmpNo, tmpDt, NMnth, NthDy
Dim BgnDt, EndDt, IsAllDy, StrtTm, EndTm, Ppl, EvntTtl, EvntDtl
' Retrieve useful info to local
BgnDt = aHC.RdItm("BgnDt"): EndDt = aHC.RdItm("EndDt")
IsAllDy = aHC.RdItm("IsAllDy"): Ppl = aHC.RdItm("Ppl")
StrtTm = aPttrn.StartTime: EndTm = aPttrn.EndTime
EvntTtl = strRplc("""", "", aHC.RdItm("EvntTtl")): EvntDtl = strRplc("""", "", aHC.RdItm("EvntDtl"))
NMnth = aPttrn.Interval ' Every Nth month
NthDy = aPttrn.DayOfMonth ' Nth day
tmpDt = aPttrn.PatternStartDate
If tmpDt < BgnDt Then
tmpNo = DateDiff("m", tmpDt, BgnDt)
tmpNo = tmpNo + NMnth - (tmpNo Mod NMnth)
tmpDt = DateAdd("m", tmpNo, tmpDt)
End If
' Adjust the date
tmpDt = DateSerial(Year(tmpDt), Month(tmpDt), NthDy)
' Loop until pass EndDt
DoRecrrng2_ = 0
Do Until tmpDt > EndDt
If tmpDt >= BgnDt And tmpDt <= EndDt Then ' Double sure
DoRecrrng2_ = DoRecrrng2_ + 1
' save the event to db
status = Add2EvntTmp(aCDO, IsAllDy, tmpDt + StrtTm, tmpDt + EndTm, _
Ppl, EvntTtl, EvntDtl)
End If
tmpDt = DateAdd("m", NMnth, tmpDt)
tmpDt = DateSerial(Year(tmpDt), Month(tmpDt), NthDy)
Loop
End Function
' MonthNth (Nth weekday) - assuming aPttrn.PatternEndDate > BgnDt
Public Function DoRecrrng3_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
Dim status, tmpNo, tmpDt, NMnth, NthWkDy, BtNoArry(), tmpFlg
Dim BgnDt, EndDt, IsAllDy, StrtTm, EndTm, Ppl, EvntTtl, EvntDtl
' Retrieve useful info to local
BgnDt = aHC.RdItm("BgnDt"): EndDt = aHC.RdItm("EndDt")
IsAllDy = aHC.RdItm("IsAllDy"): Ppl = aHC.RdItm("Ppl")
StrtTm = aPttrn.StartTime: EndTm = aPttrn.EndTime
EvntTtl = strRplc("""", "", aHC.RdItm("EvntTtl")): EvntDtl = strRplc("""", "", aHC.RdItm("EvntDtl"))
NMnth = aPttrn.Interval ' Every Nth month
NthWkDy = aPttrn.Instance
tmpDt = aPttrn.PatternStartDate
' To the month just before BgnDt
If tmpDt < BgnDt Then
tmpNo = Year(BgnDt) * 12 + Month(BgnDt) - Year(tmpDt) * 12 - Month(tmpDt)
tmpNo = tmpNo + NMnth - (tmpNo Mod NMnth)
tmpDt = DateAdd("m", tmpNo, tmpDt)
End If
' Get WkDy - MonthNth can't have multiple week day!
tmpFlg = Lng2BtNoArry(aPttrn.DayOfWeekMask, BtNoArry, 1, "")
' If tmpNo > 1 Then ' weekday or weekend day
' tmpFlg = tmpNo
' DoRecrrng3_ = -1111 ' not handled for now
' DoRecrrng3_ = DoRecrrng3x_(aCDO, aHC, aPttrn, PrmtrTyp, Prmtr)
' Exit Function
' End If
tmpNo = BtNoArry(1) ' Only one can be selected
' Adjust the date
If tmpFlg = 2 Or tmpFlg = 5 Then
tmpDt = NthWrkWkndDy2Dt(NthWkDy, tmpFlg, Month(tmpDt), Year(tmpDt), 1, "")
Else
tmpDt = NthWkDy2Dt(NthWkDy, tmpNo, Month(tmpDt), Year(tmpDt), 1, "")
End If
' Loop until pass EndDt
DoRecrrng3_ = 0
Do Until tmpDt > EndDt
If tmpDt >= BgnDt And tmpDt <= EndDt Then ' Double sure
DoRecrrng3_ = DoRecrrng3_ + 1
' save the event to db
status = Add2EvntTmp(aCDO, IsAllDy, tmpDt + StrtTm, tmpDt + EndTm, _
Ppl, EvntTtl, EvntDtl)
End If
tmpDt = DateAdd("m", NMnth, tmpDt)
If tmpFlg = 2 Or tmpFlg = 5 Then ' Adjust the date
tmpDt = NthWrkWkndDy2Dt(NthWkDy, tmpFlg, Month(tmpDt), Year(tmpDt), 1, "")
Else
tmpDt = NthWkDy2Dt(NthWkDy, tmpNo, Month(tmpDt), Year(tmpDt), 1, "")
End If
Loop
End Function
' Give the nth workday or weekend day and return the date
' Typ: 2(weekend day) 5(work day) other(error)
Public Function NthWrkWkndDy2Dt(aNth, aTyp, aMnth, aYr, PrmtrTyp, Prmtr)
Dim tmpDt
NthWrkWkndDy2Dt = Null
If aNth < 5 Then
tmpDt = DateSerial(aYr, aMnth, 1)
Cnt = 0
Do Until Cnt = aNth
WkDy = DatePart("w", tmpDt)
If aTyp = 2 And (WkDy = 1 Or WkDy = 7) Then
Cnt = Cnt + 1
ElseIf aTyp = 5 And WkDy > 1 And WkDy < 7 Then
Cnt = Cnt + 1
End If
NthWrkWkndDy2Dt = tmpDt
tmpDt = DateAdd("d", 1, tmpDt)
Loop
ElseIf aNth = 5 Then
tmpDt = DateSerial(aYr, aMnth, LstDyAMnth(aYr, aMnth, 1, ""))
Cnt = 0
Do Until Cnt > 0
WkDy = DatePart("w", tmpDt)
If aTyp = 2 And (WkDy = 1 Or WkDy = 7) Then
Cnt = 1
ElseIf aTyp = 5 And WkDy > 1 And WkDy < 7 Then
Cnt = 1
End If
NthWrkWkndDy2Dt = tmpDt
tmpDt = DateAdd("d", -1, tmpDt)
Loop
End If
End Function
' Given nth weekday and return the date
' nth(5=last, <1 error="">5=error)
Public Function NthWkDy2Dt(aNth, aDyWk, aMnth, aYr, PrmtrTyp, Prmtr)
Dim Dt
If aNth > 5 Then
NthWkDy2Dt = Null
Exit Function
End If
' 1st day of that month
Dt = DateSerial(aYr, aMnth, 1)
If aDyWk < Weekday(Dt) Then
Dt = DateAdd("d", aNth * 7 + aDyWk - Weekday(Dt), Dt)
Else
Dt = DateAdd("d", (aNth - 1) * 7 + aDyWk - Weekday(Dt), Dt)
End If
If aMnth < Month(Dt) Then
Dt = DateAdd("d", -7, Dt)
End If
NthWkDy2Dt = Dt
End Function
' BtNoArry(0)=number of bits numbers
' BtNoArry(n)=bit number + 1
' PrmtrTyp 0(reserved),
' 1(array of bit numbers where the bit is 1)
' 2(array of bits)
Public Function Lng2BtNoArry(Lng, BtNoArry, PrmtrTyp, Prmtr)
Dim Sz, Ndx, NoItm
Sz = Int(Log(Lng) / Log(2)) + 1
ReDim BtNoArry(Sz)
NoItm = 0
If PrmtrTyp = 1 Then
For Ndx = 1 To Sz
If (Lng Mod 2) = 1 Then
NoItm = NoItm + 1
BtNoArry(NoItm) = Ndx
Lng = Lng - 1
End If
Lng = Lng / 2
Next
Else
For Ndx = 1 To Sz
BtNoArry(Ndx) = Lng Mod 2
Lng = Int(Lng / 2)
Next
NoItm = Sz
End If
BtNoArry(0) = NoItm
Lng2BtNoArry = NoItm
End Function
' Save outlook appointment to event table
Public Function Appntmnt2EvntTmp(aCDO, Appntmnt, Ppl, PrmtrTyp, Prmtr)
Appntmnt2EvntTmp = Add2EvntTmp(aCDO, _
Appntmnt.AllDayEvent, _
Appntmnt.Start, _
Appntmnt.End, _
Ppl, _
strRplc("""", "", Appntmnt.Subject), _
strRplc("""", "", Appntmnt.Location) _
)
End Function
' Save parameters to event table
Public Function Add2EvntTmp(aCDO, IsAllDy, TmBgn, TmEnd, Ppl, EvntTtl, EvntDtl)
sSql = "INSERT INTO EvntTmp(AllDyEvnt, TmBgn,TmEnd,OwnrNm,EvntTtl,EvntDtl) VALUES" _
& "(" & IsAllDy & ",""" & TmBgn & """,""" & TmEnd & """,""" & Ppl _
& """,""" & EvntTtl & """,""" & EvntDtl & """);"
Add2EvntTmp = aCDO.Exct(sSql, 1, "")
End Function
' return the last day of a month
' PrmtrTyp: 0(reserved) 1(implemented)
Public Function LstDyAMnth(Yr, Mnth, PrmtrTyp, Prmtr)
Select Case Mnth
Case 1, 3, 5, 7, 8, 10, 12
LstDyAMnth = 31
Case 4, 6, 9, 11
LstDyAMnth = 30
Case 2
LstDyAMnth = DatePart("d", DateAdd("m", 1, DateSerial(Yr, 1, 31)))
Case Else
LstDyAMnth = -1111
End Select
End Function
