DOS/V Power Report 2004 June/VPR0406.ISO/STARSUITE7/EVALUATION/windows/office7/f_0218/BankHoliday.xba

Extensible Markup Language | 2004-01-12 | 5KB | 184 lines

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="BankHoliday" script:language="StarBasic">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)
    ' inserts the individual data from the table into the previously unsorted list
Dim CurEventName as String
Dim CurEvMonth as Integer
Dim CurEvDay as Integer
Dim LastIndex as Integer
Dim i as Integer
Dim DateStr as String
    LastIndex = Ubound(DlgCalModel.lstOwnData.StringItemList())
    For i = 0 To LastIndex
        If GetSelectedDateUnits(CurEvDay, CurEvMonth, i) <> SBDATEUNDEFINED Then
            CurEventName = CalGetNameOfEvent(i)
            CalInsertBankholiday(DateSerial(iSelYear, CurEvMonth, CurEvDay), CurEventName, cHolidayType_Own)
        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 + 4
        CalInsertBankholiday(lDate, HolidayName, iType)
    Next lDate
End Sub
</script:module>