VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Private Const CHRISTMAS_DAY As String = "25 Dec "
Private Const BOXING_DAY As String = "26 Dec "
Private Const NEW_YEARS_DAY As String = "1 Jan "
Private Const MAY_BEGINNING As String = "1 May "
Private Const MAY_END As String = "31 May "
Private Const AUGUST_END As String = "31 Aug "


'*****************************************************************************************
'* Name:            CGreg2Jul
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y,m,d    LONG      Gregorian date
'*
'*                  LONG      Julian Date
'*
'* Notes:           This function converts from a standard Gregorian date to the
'*                  astronomical Julian Day Number (not Julian Date - which starts again
'*                  at the beginning of each year at 1 fom Jan 1st)
'*
'*                  This function can handle dates from 1582 AD. This should be
'*                  enough scope for most uses.
'*
'*                  To convert to astronomical julian day number subtract 0.5
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function CGreg2Jul(y As Long, m As Long, d As Long) As Long

    Dim jy As Long
    Dim ja As Long
    Dim jm As Long
    Dim intgr As Long
    
    If (m > 2) Then
        jy = y
        jm = m + 1
    Else
        jy = y - 1
        jm = m + 13
    End If
    
    intgr = Fix(Fix(365.25 * jy) + Fix(30.6001 * jm) + d + 1720995)
    
    ja = Fix(0.01 * jy)
    intgr = intgr + 2 - ja + Fix(0.25 * ja)
    
    CGreg2Jul = intgr
    
End Function


'*****************************************************************************************
'* Name:            Gregorian
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      jd  --> Astronomical Julian Date
'*
'*                  Ret         DATE    Gregorian Date
'*
'* Notes:           This function returns the Gregorian calendar representation of the
'*                  Julian Day Number (1582 AD and after)
'*
'*                  Standard Gregorian Calendar rules apply
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function CJul2Greg(jd As Long) As Date

    Dim intgr As Long
    Dim j1 As Long, j2 As Long, j3 As Long
    Dim j4 As Long, j5 As Long
    Dim d As Long, m As Long, y As Long
    Dim tmp As Long
    
    intgr = Fix(jd)
    
    tmp = Fix(((intgr - 1867216) - 0.5) / 36524.25)
    j1 = intgr + 1 + tmp - Fix(0.25 * tmp)
    
    j2 = j1 + 1524
    j3 = Fix(6680# + ((j2 - 2439870) - 122.1) / 365.25)
    j4 = Fix(j3 * 365.25)
    j5 = Fix((j2 - j4) / 30.6001)
    
    d = Fix(j2 - j4 - Fix(j5 * 30.6001))
    m = Fix(j5 - 1)
    y = Fix(j3 - 4715)
    
    If m > 12 Then m = m - 12
    If m > 2 Then y = y - 1
    If y <= 0 Then y = y - 1
    
    CJul2Greg = Format$(d & "/" & m & "/" & y, "dd mmm yyyy")
    
End Function


'*****************************************************************************************
'* Name:            WeekNumber
'* Author:          Yrwyddfa
'* Date:            20th May 2005
'*
'* Parameters:      None
'*
'*                  LONG    ISO Week Number 1..53 (ISO-8601)
'*
'* Notes            "The first calendar week of a year is the one that includes the first Thursday
'*                  of that year and the last calendar week of a calendar year is the week
'*                  immediately preceding the first calendar week of the next year", ISO-8601
'*
'*                  Simply: The first week of the year is the earliest week that contains at
'*                  least four days of January. Likewise, the last week of the calendar is the
'*                  last week that contains at least four days of December.
'*
'*                  Microsoft defines the first week of the year as the week that contains
'*                  the 1st of January (which is not always right)
'*
'* Version:         20th May 2005         Created         YW
'*****************************************************************************************
Public Function WeekNumber(y As Long, m As Long, d As Long) As Long
    
    Dim fIsLeapYear As Boolean
    Dim lDayOfYear As Long
    Dim lJan1Weekday As Long
    Dim lWeekday As Long
    Dim lYearNumber As Long
    Dim h As Long
    Dim i As Long
    Dim j As Long
    Dim jd1Jan As Double
    Dim jdDate As Double
    
    ' Get Julian dates, and compute various days of year
    jd1Jan = CGreg2Jul(y, 1, 1)
    jdDate = CGreg2Jul(y, m, d)
    lDayOfYear = (jdDate - jd1Jan) + 1
    
    'Compute Weekdays
    lJan1Weekday = (jd1Jan Mod 7) + 1
    lWeekday = (jdDate Mod 7) + 1
    
    fIsLeapYear = IsLeapYear(y)
    
    ' Find if D M Y falls in Yr-1, WkN 52 or 53
    If lDayOfYear <= (8 - lJan1Weekday) And lJan1Weekday > 4 Then
        lYearNumber = y - 1
        If lJan1Weekday = 5 Or (lJan1Weekday = 6 And Not fIsLeapYear) Then
            WeekNumber = 53
        Else
            WeekNumber = 52
        End If
    Else
        lYearNumber = y
    End If
    
    ' Find if D M Y falls in Yr+1m Wk=1
    If lYearNumber = y Then
        If fIsLeapYear Then
            i = 366
        Else
            i = 365
        End If
        If (i - lDayOfYear) < (4 - lWeekday) Then
            lYearNumber = y + 1
            WeekNumber = 1
        End If
    End If
    
    ' Find if D M Y falls in Y, Wk1 to Wk53
    If lYearNumber = y Then
        j = lDayOfYear + (7 - lWeekday) + (lJan1Weekday - 1)
        WeekNumber = j \ 7
        If lJan1Weekday > 4 Then
            WeekNumber = WeekNumber - 1
        End If
    End If
    
End Function

'*****************************************************************************************
'* Name:            IsLeapYear
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y      LONG      Gregorian date (1582+)
'*
'*                  BOOLEAN     True if leapyear otherwise false
'*
'* Notes:           If year is divisble by 4 and not divisble by 100 unless divisble
'*                  by 400 then the year is a leap year
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function IsLeapYear(y As Long) As Boolean
    IsLeapYear = (y Mod 4 = 0 And y Mod 100 <> 0) Or y Mod 400 = 0
End Function

'*****************************************************************************************
'* Name:            Weekday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y,m,d      LONG      Gregorian date (1582+)
'*
'*                  LONG      1..7
'*
'* Notes:           Returns the weekday where Monday=1, and Sunday=7
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function Weekday(y As Long, m As Long, d As Long) As Long

    Dim jdDate As Double
    
    jdDate = CGreg2Jul(y, m, d)
    Weekday = (jdDate Mod 7) + 1
    
End Function

'*****************************************************************************************
'* Name:            HolidayGoodFriday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The date Good Friday falls in the given year
'*
'* Notes:           Simple, really. Get Easter Sunday and take two days from it.
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayGoodFriday(y As Long) As Date
    HolidayGoodFriday = (HolidayEasterSunday(y) - 2)
End Function

'*****************************************************************************************
'* Name:            HolidayEasterSunday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        Easter Sunday for the given year
'*
'* Notes:           Easter falls on the first Sunday following the ecclesiastical full moon
'*                  that occurs on or after the day of the vernal equinox
'*                  This particular ecclesiastical full moon is the 14th day of a tabular
'*                  lunation (new moon) and the vernal equinox is fixed as March 21
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayEasterSunday(y As Long) As Date
    
    Dim d As Integer
    
    d = (((255 - 11 * (y Mod 19)) - 21) Mod 30) + 21
    HolidayEasterSunday = (CGreg2Jul(y, 3, 1) - 2415019) + d + (d > 48) + 6 - ((y + y \ 4 + d + (d > 48) + 1) Mod 7)
    
End Function

'*****************************************************************************************
'* Name:            HolidayEasterMonday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        Easter Monday for the given year
'*
'* Notes:           Simple, really: Get Easter Sunday then increment one!
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayEasterMonday(y As Long) As Date
    HolidayEasterMonday = (HolidayEasterSunday(y) + 1)
End Function

'*****************************************************************************************
'* Name:            Mayday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        Mayday for the given year
'*
'* Notes:           Mayday is the first Monday in May
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function MayDay(y As Long) As Date
    MayDay = CDate(MAY_BEGINNING & y) + (7 - Weekday(y, 5, 1) + 1)
End Function

'*****************************************************************************************
'* Name:            BankHolidaySpring
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The UK Spring Bank Holiday
'*
'* Notes:           The UK Spring Bank Holiday falls on the last Monday of May
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function BankHolidaySpring(y As Long) As Date
    BankHolidaySpring = CDate(MAY_END & y) - (Weekday(y, 5, 31) - 1)
End Function

'*****************************************************************************************
'* Name:            BankHolidaySummer
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The UK Summer Bank Holiday
'*
'* Notes:           The UK Summer Bank Holiday falls on the last Monday of August
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function BankHolidaySummer(y As Long) As Date
    BankHolidaySummer = CDate(AUGUST_END & y) - (Weekday(y, 8, 31) - 1)
End Function

'*****************************************************************************************
'* Name:            HolidayNewYearsDay
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The UK New Years day holiday
'*
'* Notes:           The UK New Years day holiday is on 1 Jan unless 1 Jan is a weekend.
'*                  In this case the holiday falls on the succeding Monday.
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayNewYearsDay(y As Long) As Date
    
    Dim wkDay As Long
    
    wkDay = Weekday(y, 1, 1)
    If wkDay > 5 Then
        HolidayNewYearsDay = CDate(NEW_YEARS_DAY & y) + (7 - wkDay + 1)
    Else
        HolidayNewYearsDay = CDate(NEW_YEARS_DAY & y)
    End If
    
End Function

'*****************************************************************************************
'* Name:            HolidayChristmasDay
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The UK Christmas day holiday
'*
'* Notes:           The UK Christmas day holiday is on 25 Dec unless 25 Dec is a weekend.
'*                  In this case, for either Saturday or Sunday, the Christmas day holiday
'*                  falls two days later; effectively preserving a Boxing Day Monday if it
'*                  occurs
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayChristmasDay(y As Long) As Date

    Dim wkDay As Long
    
    wkDay = Weekday(y, 12, 25)
    If wkDay > 5 Then
        HolidayChristmasDay = CDate(CHRISTMAS_DAY & y) + 2
    Else
        HolidayChristmasDay = CDate(CHRISTMAS_DAY & y)
    End If
       
End Function

'*****************************************************************************************
'* Name:            HolidayBoxingDay
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE        The UK Boxing day holiday
'*
'* Notes:           The UK Boxing day holiday is on 26 Dec unless 26 Dec is a weekend.
'*                  If it is a weekend two days are added to make the holiday fall in the
'*                  succeeding week.
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidayBoxingDay(y As Long) As Date

    Dim wkDay As Long
    
    wkDay = Weekday(y, 12, 26)
    If wkDay > 5 Then
        HolidayBoxingDay = CDate(BOXING_DAY & y) + 2
    Else
        HolidayBoxingDay = CDate(BOXING_DAY & y)
    End If
    
End Function

'*****************************************************************************************
'* Name:            HolidaysYear
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      y         LONG      Gregorian year
'*
'*                  DATE()    Array containing all the UK holidays for the given year
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function HolidaysYear(y As Long) As Date()

    Dim Ret(0 To 7) As Date
    
    Ret(0) = HolidayNewYearsDay(y)
    Ret(1) = HolidayGoodFriday(y)
    Ret(2) = HolidayEasterMonday(y)
    Ret(3) = MayDay(y)
    Ret(4) = BankHolidaySpring(y)
    Ret(5) = BankHolidaySummer(y)
    Ret(6) = HolidayChristmasDay(y)
    Ret(7) = HolidayBoxingDay(y)
    
    HolidaysYear = Ret
    
End Function

'*****************************************************************************************
'* Name:            IsDayHoliday
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      dDte    DATE    Date to test
'*
'*                  BOOLEAN     True if dDte is a holiday otherwise false
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function IsDayHoliday(dDte As Date) As Boolean

    Dim Holidays() As Date
    Dim lCtr As Long
    
    Holidays = HolidaysYear(Year(dDte))
    IsDayHoliday = False
    
    For lCtr = 0 To UBound(Holidays)
        If Holidays(lCtr) = dDte Then
            IsDayHoliday = True
            Exit For
        End If
    Next
    
End Function


'*****************************************************************************************
'* Name:            WorkingDays
'* Author:          Yrwyddfa
'* Date:            20th May 2004
'*
'* Parameters:      dFrom    DATE    Date from which to start
'*                  dTo      DATE    Date of which to end
'*
'*                  LONG    The number of working days in the period specified
'*
'* Notes            This function counts the days between the period ignoring working
'*                  days and weekends
'*
'* Version:         20/05/2004          Created         YW
'*****************************************************************************************
Public Function WorkingDays(dFrom As Date, dTo As Date) As Long

    Dim lCtr As Long
    Dim dDte As Date
    
    If dFrom < dTo Then
    
        dDte = dFrom
        
        Do Until dDte = Format$(dTo, "dd/mm/yyyy")
            If Weekday(Year(dDte), Month(dDte), Day(dDte)) < 6 Then
                If Not IsDayHoliday(dDte) Then
                    lCtr = lCtr + 1
                End If
            End If
            dDte = dDte + 1
        Loop
        
    Else
        WorkingDays = 0
    End If
    
    WorkingDays = lCtr
    
End Function

'*****************************************************************************************
'* Name:            nWeeksBack
'* Author:          Yrwyddfa
'* Date:            24th May 2004
'*
'* Parameters:      dFrom      DATE     Date from which to start
'*                  Weeks      LONG     Number of weeks to go back
'*
'*                  DATE        The date n weeks ago
'*
'* Notes            This function calculates the date n weeks ago
'*
'* Version:         24/05/2004          Created         YW
'*****************************************************************************************
Public Function nWeeksBack(dFrom As Date, Weeks As Long) As Date

    Dim ljFrom As Long
    Dim lDate As Long
    
    ljFrom = CGreg2Jul(Year(dFrom), Month(dFrom), Day(dFrom))
    lDate = ljFrom - (7 * Weeks)
    
    nWeeksBack = CJul2Greg(lDate)
    
End Function

'*****************************************************************************************
'* Name:            nWeeksForward
'* Author:          Yrwyddfa
'* Date:            24 May 2004
'*
'* Parameters:      dFrom      DATE     Date from which to start
'*                  Weeks      LONG     Number of weeks to go forward
'*
'*                  DATE        The date n weeks ago
'*
'* Notes            This function calculates the date n weeks in the future
'*
'* Version:         24/05/2004          Created         YW
'*****************************************************************************************
Public Function nWeeksForward(dFrom As Date, Weeks As Long) As Date

    Dim ljFrom As Long
    Dim lDate As Long
    
    ljFrom = CGreg2Jul(Year(dFrom), Month(dFrom), Day(dFrom))
    lDate = ljFrom + (7 * Weeks)
    
    nWeeksForward = CJul2Greg(lDate)
    
End Function

'*****************************************************************************************
'* Name:            WeekBeginning
'* Author:          Yrwyddfa
'* Date:            28 May 2004
'*
'* Parameters:      dDate       The day on which to calculate
'*
'*                  DATE        The Monday of the week dDate is in
'*
'* Version:         28/05/2004          Created         YW
'*****************************************************************************************
Public Function WeekBeginning(dDate As Date) As Date
    WeekBeginning = (dDate - (Weekday(Year(dDate), Month(dDate), Day(dDate)) - 1))
End Function