Attribute VB_Name = "MDates"
'*****************************************************************************************
'* Name:            MDates
'* Author:          Mark Wilson
'*
'* Copyright:       (c) Mark Wilson. All Rights Reserved.
'*
'* Date:            25 April 2001
'*
'* Sub-routines:    Julian
'*                  Gregorian
'*                  IsLeapYear
'*                  DaysInMonth
'*                  IsValidDate
'*
'* Notes:           This module is intended to replace/extend the VB date libraries. Historical dates
'*                  are notorious to handle within VB (v6) such as no way to represent BC years within
'*                  the date type primitive.
'*
'*                  I guess this should really be published in a standard C DLL (for efficiency)
'*
'*                  Much of the following code is algorithmic; this means it doesn't make for the
'*                  best reading in the world. Where I have used an algorithm already published the
'*                  the author is given appropriate credit.
'*
'* Supported        Visual Basic 5,6
'*
'* Version:         25/04/2001          Created         MW
'*****************************************************************************************

Option Explicit

'*****************************************************************************************
'* Name:            Julian
'* Author:          Mark Wilson
'* Date:            23 January 2001
'*
'* Parameters:      lDay    --> LONG     Day number
'*                  lMonth  --> LONG     Month Number
'*                  lYear   --> LONG     4 digit Year Number
'*
'*                  Ret         DOUBLE   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 4713 BC to 4713 AD+ This should be
'*                  enough scope for most uses. It is also the fundamental Julian Day
'*                  Number Epoch from Scaliger's Initial Epoch.
'*
'*                  This algorithm has been adapted from the one that appears in
'*                  'Astronomy with your Personal Computer' by Peter Duffat Smith (2nd Ed)
'*
'* Version:         23/01/2001          Created         MW
'*****************************************************************************************
Public Function Julian(ByVal lDay As Long, ByVal lMonth As Long, ByVal lYear As Long) As Double

    Dim dYear As Double
    Dim dMonth As Double
    Dim dDay As Double
    
    '*********************************
    '* Algorithm place holders . . .
    '*********************************
    Dim a As Double
    Dim b As Double
    Dim c As Double
    Dim d As Double
    
    '********************************
    '* Parse VB date primitive . . .
    '********************************
    dDay = CDbl(lDay)
    dMonth = CDbl(lMonth)
    dYear = CDbl(lYear)
    
    If dMonth < 3 Then
        dMonth = dMonth + 12
        dYear = dYear - 1
    End If
    
    '**************************************************
    '* Check for Julian => Gregorian change over . . .
    '**************************************************
    
    If CLng(lYear & Format(lMonth, "00") & Format(lDay, "00")) < 15821115 Then
        b = 0
    Else
        a = Int(dYear / 100)
        b = 2 - a + Int(a / 4)
    End If

    c = Int(365.25 * dYear) - 694025
    
    '******************************************
    '* Further calculations for BC years . . .
    '******************************************
    If dYear < 0 Then
        c = Fix((365.25 * dYear) - 0.75) - 694025
    End If
    
    d = Int(30.6001 * (dMonth + 1))
    
    '******************************************
    '* Add it all up to get Julian Date . . .
    '******************************************
    Julian = 2415020 + b + c + d + dDay - 0.5
    Exit Function

End Function


'*****************************************************************************************
'* Name:            Gregorian
'* Author:          Mark Wilson
'* Date:            23 January 2001
'*
'* Parameters:      Julian  --> Astronomical Julian Date
'*
'*                  Ret         DOUBLE   Julian Date
'*
'* Notes:           This function returns the Gregorian calendar representation of the
'*                  Julian Day Number
'*
'*                  Standard Gregorian Calendar rules apply
'*
'* Version:         23/01/2001          Created         MW
'*****************************************************************************************
Public Function Gregorian(ByVal Julian As Double) As Date

    On Error GoTo ERR_Jul2Greg:
    
    Dim i As Double
    Dim fd As Double
    
    '********************************
    '* Algorithm Place Holders . . .
    '********************************
    Dim a As Double
    Dim b As Double
    Dim c As Double
    Dim d As Double
    Dim g As Double
    
    Dim dDay As Double
    Dim dMonth As Double
    Dim dYear As Double
    
    d = (Julian - 2415020#) + 0.5
    i = Fix(d)
    fd = d - i
    
    If fd = 1 Then
        fd = 0
        i = i + 1
    End If
    
    '***************************************
    '* Deal with the Gregorian Change . . .
    '***************************************
    If i > -115860 Then
        a = Fix((i / 36524.25) + 0.99835726) + 14#
        i = i + 1# + a - Fix(a / 4#)
    End If
    
    '*****************************
    '* Main algorithm body  . . .
    '*****************************
    b = Fix((i / 365.25) + 0.802601)
    c = i - Fix((365.25 * b) + 0.750001) + 416#
    g = Fix(c / 30.6001)
    
    '*******************************
    '* Work our gregorian date . . .
    '*******************************
    dMonth = g - 1
    dDay = c - Fix(30.6001 * g) + fd
    dYear = b + 1899#
    
    '*************************
    '* Final adjustments . . .
    '*************************
    If g > 13.5 Then dMonth = g - 13
    If dMonth < 2.5 Then dYear = b + 1900
    
    '********************
    '* No Year zero . . .
    '********************
    If dYear < 1 Then
        Err.Raise 1, "MDate.Jul2Greg", "There is no year zero"
    End If
    
    dDay = Int(dDay)
    
    Gregorian = CDate(CStr(dDay) & "/" & CStr(dMonth) & "/" & CStr(dYear))
    Exit Function
    
ERR_Jul2Greg:

End Function


'*****************************************************************************************
'* Name:            IsValidDate
'* Author:          Mark Wilson
'* Date:            23 January 2001
'*
'* Parameters:      lDay    -->     Gregorian Day Number
'*                  lMonth  -->     Gregorian Month Number
'*                  lYear   -->     Gregorian Year Number
'*
'*                  Ret         BOOLEAN     Yes/No  depending on date validity
'*
'* Notes:           This function determines whether the date is valid, and whether
'*                  the date will map into the Julian Day Number Epoch.
'*
'*                  Standard Gregorian Calendar rules apply, as well as Julian Day
'*                  Number Rules
'*
'* Version:         23/01/2001          Created         MW
'*****************************************************************************************
Private Function IsValidDate(lDay As Long, lMonth As Long, lYear As Long) As Boolean

   Dim fRet As Boolean
    
    'Assume date is valid . . .
    fRet = True
    
    'Check special cases for years
    Select Case lYear
    
        Case Is = 1582
            'Proleptic Julian to Gregorian switch
            If lMonth = 10 Then
                If lDay > 4 And lDay < 15 Then
                    fRet = False
                End If
            End If
            
        Case Is = 0
            'No Year Zero . . .
            fRet = False
            
        Case Is < 4713
            'Outside of specified Epoch
            fRet = False
            
        Case Is > 4713
            'Outside of specified Epoch
            fRet = False
            
        Case Else
            
    End Select
    
    'Valid year, but what about the rest . . .
    If lMonth < 1 Or lMonth > 12 Then
        'Out of month range
        fRet = False
    Else
        If lDay < 1 Or lDay > DaysInMonth(lMonth, lYear) Then
            'Out of day range
            fRet = False
        End If
    End If
    
    IsValidDate = fRet
    
End Function

'*****************************************************************************************
'* Name:            DaysInMonth
'* Author:          Mark Wilson
'* Date:            23 January 2001
'*
'* Parameters:      lMonth  -->     Gregorian Month Number
'*                  lYear   -->     Gregorian Year Number
'*
'*                  LONG     The amount of days in the month
'*
'* Notes:           Where 'a'=Month>=8,'b'=Month evenly divisble by 2,'c'=Month=2 . . .
'*
'*                      Truth Table         :f=a'bc' or ab'c'
'*                      K-Map reduction     :f=ab' or a'bc'
'*
'*                  It's probably faster to use an array with the month days entered
'*                  against the month ordinal - but what the hell, this was more fun (?)
'*
'* Version:         23/01/2001          Created         MW (on a concept by JGW)
'*****************************************************************************************
Private Function DaysInMonth(lMonth As Long, lYear As Long) As Long

    '**********************************
    '* Proposition Place holders . . .
    '**********************************
    Dim a As Boolean
    Dim b As Boolean
    Dim c As Boolean

    '********************************
    '* Proposition assignments . . .
    '********************************
    a = lMonth >= 8
    b = lMonth Mod 2 = 0
    c = lMonth = 2
    
    '************************
    '* Logic Resolution . . .
    '************************
    MonthDays = 31 + ((a And Not (b)) Or (Not (a) And b And Not (c))) + _
                (3 * c) - (c And IsLeapYear(lYear))
    
End Function

Private Function IsLeapYear(lYear As Long) As Boolean

    '*****************************************
    '* Works out if year is a leap year . . .
    '*****************************************
    
    '***************************************************
    '* 'a' is Year is divisble by 4
    '* 'b' is Year is divisible by 100
    '* 'c' is Year is divisible by 400
    '*
    '* Truth table logic    : f = ab'c' or ab'c or abc
    '* Minimised by K-Map   : f = ac or ab'
    '**************************************************
    
    Dim a As Boolean
      
    a = lYear Mod 4 = 0
    
    IsLeapYear = (a And lYear Mod 400 = 0) Or (a And lYear Mod 100 <> 0)
    
End Function