Option Explicit Sub Main() Call CalAutopilotTable() End Sub Function CalEasterTable&(byval Year%) Dim B%,C%,D%,E%,F%,G%,H%,I%,K%,L%,M%,N%,O%, nMonth%, nDay% N = Year% mod 19 B = int(Year% / 100) C = Year% mod 100 D = int(B / 4) E = B mod 4 F = int((B + 8) / 25) G = int((B - F + 1) / 3) H =(19 * N + B - D - G + 15) mod 30 I = int(C / 4) K = C mod 4 L =(32 + 2 * E + 2 * I - H - K) mod 7 M = int((N + 11 * H + 22 * L) / 451) O = H + L - 7 * M + 114 nDay = O mod 31 + 1 nMonth = int(O / 31) CalEasterTable& = DateSerial(Year, nMonth,nDay) End Function ' Note: the following algorithm is valid only till the Year 2100. ' but I have no Idea from which date in the paste it is valid Function CalOrthodoxEasterTable(ByVal iYear as Integer) as Long Dim R1%, R2%, R3%, RA%, R4%, RB%, R5%, RC% Dim lDate as Long R1 = iYear mod 19 R2 = iYear mod 4 R3 = iYear mod 7 RA =19 * R1 + 16 R4 = RA mod 30 RB = 2 * R2 + 4 * R3 + 6 * R4 R5 = RB mod 7 RC = R4 + R5 lDate = DateSerial(iYear, 4,4) CalOrthodoxEasterTable() = lDate + RC End Function Sub CalInitGlobalVariablesDate() Dim i as Integer For i = 1 To 374 CalBankholidayName$(i) = "" CalTypeOfBankHoliday%(i) = cHolidayType_None Next End Sub Sub CalInsertBankholiday(byval CurDate as Long, byval EventName as String, ByVal iLevel as Integer) Dim iDay iDay =(Month(CurDate)-1)*31 +Day(CurDate) If 0 <> CalTypeOfBankHoliday(iDay) Then If iLevel < CalTypeOfBankHoliday(iDay) Then CalTypeOfBankHoliday(iDay) = iLevel End If Else CalTypeOfBankHoliday(iDay) = iLevel End If If CalBankHolidayName(iDay) = "" Then CalBankHolidayName(iDay) = EventName Else CalBankHolidayName(iDay) = CalBankHolidayName(iDay) & " / " & EventName End If End Sub Function CalIsLeapYear(ByVal iYear as Integer) as Boolean CalIsLeapYear = iYear Mod 4 = 0 End Function Function CalMaxDayInMonth(ByVal iYear as Integer, ByVal iMonth as Integer) as Integer ' delivers the maximum Day of a month in a certain year Dim TmpDate as Long Dim MaxDay as Long MaxDay = 28 TmpDate = DateSerial(iYear, iMonth, MaxDay) While Month(TmpDate) = iMonth MaxDay = MaxDay + 1 TmpDate = TmpDate + 1 Wend Maxday = MaxDay - 1 CalMaxDayInMonth() = MaxDay End Function Function CalGetIntOfShortMonthName(ByVal MonthName as String) as Integer Dim i as Integer Dim nMonth as Integer nMonth = Val(MonthName) If (1 <= nMonth And 12 >= nMonth) Then CalGetIntOfShortMonthName = nMonth Exit Function End If MonthName = UCase(Trim(Left(MonthName, 3))) For i = 0 To 11 If (UCase(cCalShortMonthNames(i)) = MonthName) Then CalGetIntOfShortMonthName = i+1 Exit Function End If Next ' Not Found CalGetIntOfShortMonthName = 0 End Function Sub CalInsertOwnDataInTables(ByVal iSelYear as Integer) ' Fügt die eigenen Individuellen Daten aus der Tabelle in die ' bereits erstellte unsortierte Tabelle ein. Dim CurEventName as String Dim CurYear as Integer Dim CurMonth as Integer Dim CurDay as Integer Dim LastIndex as Integer Dim i as Integer LastIndex = Ubound(DlgCalModel.lstOwnData.StringItemList()) For i = 0 To LastIndex CurYear = CalGetYearOfEvent(i) If DlgCalModel.lstOwnData.StringItemList(i) <> "" Then If (CurYear = iSelYear) Or (CurYear = 0) Then CurMonth = CalGetMonthofEvent(i) CurDay = CalGetDayofEvent(i) CurEventName = CalGetNameOfEvent(i) CalInsertBankholiday(DateSerial(CurYear, CurMonth, CurDay), CurEventName, cHolidayType_Own) End If End If Next End Sub ' Finds eg the first,second Monday in a month ' Note: in This Function the week starts with the Sunday Function GetMonthDate(YearInt as Integer, iMonth as Integer, iWeekDay as Integer, iOffset as Integer) Dim bFound as Boolean Dim lDate as Long ' 1st Tue in Nov : Election Day, Half bFound = False lDate = DateSerial(YearInt, iMonth, 1) Do If iWeekDay = WeekDay(lDate) Then bFound = True Else lDate = lDate + 1 End If Loop Until bFound GetMonthDate = lDate + iOffset End Function ' Finds the next weekday after a fixed date ' e.g. Midsummerfeast in Sweden: next Saturday after 20th June Function GetNextWeekDay(iYear as Integer, iMonth as Integer, iDay as Integer, iWeekDay as Integer) Dim lDate as Long Dim iCurWeekDay as Integer lDate = DateSerial(iYear, iMonth, iDay) iCurWeekDay = WeekDay(lDate) While iCurWeekDay <> iWeekDay lDate = lDate + 1 iCurWeekDay = WeekDay(lDate) Wend GetNextWeekDay() = lDate End Function Sub AddFollowUpHolidays(ByVal lStartDate as Long, iCount as Integer, HolidayName as String, iType as Integer) Dim lDate as Long For lDate = lStartDate + 1 To lStartDate + iCount CalInsertBankholiday(lDate, HolidayName, iType) Next lDate End Sub