Date Related Code - Age, Weekdays, Holidays, Julian, etc.

[dbasnett]

Part1

#Region "What they do"
    'DrawingDate - Countdown to a specific hour, on a specific Day of the Week
    '   e.g. next lottery drawing
    'AgeCalc - given two dates returns age as years and days
    'WeekDays - given two dates returns the count of "week days" 
    'isHoliday - given a date, returns true if it is a holiday see Holidays() 
    'ListHolidays - given a date, returns a list of holidays in that year see Holidays()
    'toJulian - converts datetime to julian date
    'fromJulian - returns the date based on a julian date
    'Friday13 - returns a list of months with a Friday the 13th
#End Region

    Public Function DrawingDate(ByVal DayOfWeek1 As DayOfWeek, _
                            ByVal TimeWhen As DateTime, _
                            Optional ByVal DayOfWeek2 As DayOfWeek = Nothing) As String

        Dim day1 As Integer = DayOfWeek1 'set days of interest = if only one
        Dim day2 As Integer

        If DayOfWeek2 = Nothing Then
            day2 = day1
        Else
            day2 = DayOfWeek2
        End If

        Dim nxtDrwD1 As New TimeSpan 'a next draw date
        Dim nxtDrwD2 As New TimeSpan 'a next draw date

        Dim TheNextDraw As New TimeSpan 'the one selected

        Dim OneWeek As New TimeSpan(7, 0, 0, 0) 'one week timespan

        'dummy date = now @ TimeWhen Time
        Dim dd As DateTime = New DateTime(DateTime.Now.Year, _
                                         DateTime.Now.Month, _
                                         DateTime.Now.Day, _
                                         TimeWhen.Hour, _
                                         TimeWhen.Minute, _
                                         TimeWhen.Second)


        Dim dd1 As DateTime = dd
        Dim dd2 As DateTime = dd

        'calculate closest two days
        dd1 = dd.AddDays(day1 - dd.DayOfWeek)
        dd2 = dd.AddDays(day2 - dd.DayOfWeek)

        'compute difference between the dates and now
        nxtDrwD1 = dd1 - DateTime.Now
        nxtDrwD2 = dd2 - DateTime.Now

        'if they are in the past advance them a week
        If nxtDrwD1.TotalMilliseconds <= 0 Then nxtDrwD1 = nxtDrwD1.Add(OneWeek)
        If nxtDrwD2.TotalMilliseconds <= 0 Then nxtDrwD2 = nxtDrwD2.Add(OneWeek)

        'select smaller to use
        If nxtDrwD2.TotalMilliseconds <= nxtDrwD1.TotalMilliseconds Then
            TheNextDraw = nxtDrwD2
            dd = dd2
        Else
            TheNextDraw = nxtDrwD1
            dd = dd1
        End If

        Dim s As String = String.Format("The next draw will be on {0}.  {1} days  {2}:{3}:{4}", _
                                    dd.ToShortDateString, _
                                    TheNextDraw.Days.ToString, _
                                    TheNextDraw.Hours.ToString.PadLeft(2, "0"c), _
                                    TheNextDraw.Minutes.ToString.PadLeft(2, "0"c), _
                                    TheNextDraw.Seconds.ToString.PadLeft(2, "0"c))
        Return s
    End Function

    Public Function AgeCalc(ByVal DatePast As DateTime, _
                                Optional ByVal DateFuture As DateTime = Nothing) As String
        'calculate age using two dates. the age will be years and days
        'USE:
        'Dim ageSTR() As String = AgeCalc(#2/29/1008#, #2/28/2009#).Split("|"c)

        'Debug.WriteLine(ageSTR(0)) 'years
        'Debug.WriteLine(ageSTR(1)) 'days
        'Debug.WriteLine(ageSTR(2)) 'how long calculation took (in ticks)
        '
        'note - the wonderful thing about DateSerial is that it takes care of 
        'Leap Birthdays AKA leaplings
        'a leaplings b-day is 3/1 for non-leap years
        Dim dp, df, nxtAnniv As DateTime, retval As String, ts As New TimeSpan
        Dim years, days As Integer, stpw As New Stopwatch
        stpw.Start() 'provide metric
        If DateFuture = Nothing Then DateFuture = DateTime.Now 'use now for future date
        If DatePast > DateFuture Then 'make sure the past is the past
            dp = DateFuture
            df = DatePast
        Else
            dp = DatePast
            df = DateFuture
        End If
        years = df.Year - dp.Year 'calculate years
        'create next "birthday"
        'nxtAnniv = New System.DateTime(df.Year, dp.Month, dp.Day) 'does not take care of leap b-day
        nxtAnniv = DateSerial(df.Year, dp.Month, dp.Day) 'takes care of leap b-day
        If nxtAnniv > df Then 'is the next "birthday" > future date
            years -= 1 'yes, adjust year
            nxtAnniv = DateSerial(df.Year - 1, dp.Month, dp.Day) 're-create so it is before future
        End If
        ts = df - nxtAnniv 'will give days
        days = ts.Days
        retval = years.ToString & "|" & days.ToString   'create return value
        stpw.Stop() 'how long did it take?
        retval &= "|" & stpw.ElapsedTicks.ToString
        Return retval
    End Function

    Public Function WeekDays(ByVal DatePast As DateTime, _
                                Optional ByVal DateFuture As DateTime = Nothing) As Integer
        'calculate the number of weekdays (M-F) between
        'two dates, inclusive of those dates.
        Dim dtpst, dtfut As DateTime, RetVal As Integer = 0
        Dim calcDy As TimeSpan
        If DateFuture = Nothing Then DateFuture = DateTime.Now 'use now for future date
        If DatePast > DateFuture Then 'make sure the past is the past
            dtpst = DateFuture
            dtfut = DatePast
        Else
            dtpst = DatePast
            dtfut = DateFuture
        End If
        'Force dates to Sunday
        Do While dtpst <= dtfut AndAlso dtpst.DayOfWeek <> DayOfWeek.Sunday
            If inclDay(dtpst) Then RetVal += 1
            dtpst = DateSerial(dtpst.Year, dtpst.Month, dtpst.Day + 1)
        Loop
        Do While dtpst <= dtfut AndAlso dtfut.DayOfWeek <> DayOfWeek.Sunday
            If inclDay(dtfut) Then RetVal += 1
            dtfut = DateSerial(dtfut.Year, dtfut.Month, dtfut.Day - 1)
        Loop
        'at this point both dates are on Sunday, so total days should be a multiple of 7
        calcDy = dtfut - dtpst 'the timespan has total days between future-past
        'If calcDy.TotalDays Mod 7 <> 0 Then Stop 'debug
        'each of the 7 day weeks, convert to 5 day weeks
        If calcDy.TotalDays > 0 Then RetVal += CInt((CLng(calcDy.TotalDays) \ 7) * 5)
        Return RetVal
    End Function

    Public Function inclDay(ByVal d As DateTime) As Boolean
        If d.DayOfWeek <> DayOfWeek.Saturday AndAlso _
            d.DayOfWeek <> DayOfWeek.Sunday _
            Then Return True Else Return False
    End Function

    Public Function toJulian(ByVal dt As DateTime) As Double 'returns the date as a double=julian date
        'toJulian - converts datetime to julian date
        'VB .Net implementation of:
        'based on - http://www.astro.uu.nl/~strous/AA/en/reken/juliaansedag.html
        'with time code added

        'dt is assumed to be UTC datetime

        Dim c, d, m, j, JulianDate As Double
        'encode time
        Dim t As Double = ((dt.Hour * 60 * 60) + (dt.Minute * 60) + (dt.Second)) / (24 * 60 * 60)
        d = dt.Day + t 'the day portion = the day + the time as calculated above
        m = dt.Month
        j = dt.Year
        If m < 3 Then
            m += 12
            j -= 1
        End If
        c = 2 - Math.Floor(j / 100) + Math.Floor(j / 400)
        JulianDate = Math.Floor(1461 * (j + 4716) / 4) + Math.Floor(153 * (m + 1) / 5) + d + c - 1524.5
        Return JulianDate
    End Function

    Public Function fromJulian(ByVal JDt As Double) As DateTime
        'fromJulian - returns the date based on a julian date
        'VB .Net implementation of:
        'based on - http://www.astro.uu.nl/~strous/AA/en/reken/juliaansedag.html
        'with time code added

        Dim RetVal As DateTime
        Dim d, e, h, i, j, m, n, p, q, s1, s2, s3, s4 As Double
        j = JDt
        p = Math.Floor(j + 0.5)
        s1 = p + 68569
        n = Math.Floor(4 * s1 / 146097)
        s2 = s1 - Math.Floor((146097 * n + 3) / 4)
        i = Math.Floor(4000 * (s2 + 1) / 1461001)
        s3 = s2 - Math.Floor(1461 * i / 4) + 31
        q = Math.Floor(80 * s3 / 2447)
        e = s3 - Math.Floor(2447 * q / 80)
        s4 = Math.Floor(q / 11)
        m = q + 2 - 12 * s4
        j = 100 * (n - 49) + i + s4
        d = e + JDt - p + 0.5
        h = d - (Math.Floor(d))
        d = d - h
        RetVal = DateSerial(CInt(j), CInt(m), CInt(d))
        RetVal = RetVal.AddDays(h)
        Return (RetVal)
    End Function

    Public Function NumOfMonths(ByVal dtEarlier As DateTime, _
                                 ByVal dtLater As DateTime) As Integer
        If dtEarlier < dtLater Then
            Return (dtLater.Month - dtEarlier.Month) + ((dtLater.Year - dtEarlier.Year) * 12) + 1
        Else
            Return -1
        End If
    End Function

[dbasnett]

Part 2

    Public Function Friday13(ByVal DatePast As DateTime, _
                                Optional ByVal DateFuture As DateTime = Nothing) As List(Of String)
        'Friday13 - returns a list of months with a Friday the 13th
        Dim dp, df, chkDT As DateTime, retval As New List(Of String)
        If DateFuture = Nothing Then DateFuture = DatePast 'user wants to know if the month has Friday the 13th
        If DatePast > DateFuture Then 'make sure the past is the past
            dp = DateFuture
            df = DatePast
        Else
            dp = DatePast
            df = DateFuture
        End If
        'if the first day of a month is sunday then that month will have Friday the 13th
        Do While dp <= DateFuture
            chkDT = DateSerial(dp.Year, dp.Month, 1)
            If chkDT.DayOfWeek = DayOfWeek.Sunday Then
                retval.Add(dp.ToString("MMMM yyyy"))
            End If
            dp = dp.AddMonths(1)
        Loop
        Return retval
    End Function

    Public Function Easter(ByVal y As Integer) As DateTime
        'VB .Net implementation of:
        'http://aa.usno.navy.mil/faq/docs/easter.php
        Dim c, d, i, j, k, l, m, n As Integer
        c = y \ 100
        n = y - 19 * (y \ 19)
        k = (c - 17) \ 25
        i = c - c \ 4 - (c - k) \ 3 + 19 * n + 15
        i = i - 30 * (i \ 30)
        i = i - (i \ 28) * (1 - (i \ 28) * (29 \ (i + 1)) * ((21 - n) \ 11))
        j = y + y \ 4 + i + 2 - c + c \ 4
        j = j - 7 * (j \ 7)
        l = i - j
        m = 3 + (l + 40) \ 44
        d = l + 28 - 31 * (m \ 4)
        Easter = DateSerial(y, m, d)
    End Function

    Public Function isHoliday(ByVal theDate As DateTime) As String
        'check to see if date is a holiday
        'returns name if it is, else an empty string
        If holidayDates.Count = 0 OrElse holidayDates(0).Year <> theDate.Year Then initHolidays(theDate.Year)
        Dim idx As Integer = holidayDates.IndexOf(DateSerial(theDate.Year, theDate.Month, theDate.Day))
        If idx <> -1 Then Return holidayNames(idx) Else Return String.Empty
    End Function

    Public Function ListHolidays(ByVal theDate As DateTime) As List(Of String)
        'return a list of holidays 
        'holiday name,date
        '
        Dim RetVal As New List(Of String)
        If holidayDates.Count = 0 OrElse holidayDates(0).Year <> theDate.Year Then initHolidays(theDate.Year)
        For idx As Integer = 0 To holidayDates.Count - 1
            RetVal.Add(holidayNames(idx) & "," & holidayDates(idx).ToShortDateString)
        Next
        Return RetVal
    End Function

    Public Sub initHolidays(ByVal yr As Integer)
        holidayDates.Clear()
        Dim eastR As DateTime = Easter(yr)
        Dim s() As String, dt As DateTime, parts() As String
        For x As Integer = 0 To Holidays.Length - 1
            s = Holidays(x).Split(","c)
            s(0) = s(0).Trim
            s(1) = s(1).Trim
            If Not DateTime.TryParse(s(1) & "/" & yr.ToString, dt) Then
                parts = s(1).Split("-"c)
                Select Case True
                    Case s(1).StartsWith("*") 'Easter
                        If parts(0) = "*" Then 'Easter
                            dt = eastR
                            Exit Select
                        Else 'Ash Wednesday, Good Friday, Palm Sunday
                            parts(0) = parts(0).Replace("*", "")
                            If parts.Length = 1 Then
                                dt = (eastR.AddDays(-CDbl(parts(0)))) 'ash wednesday
                            Else 'Good Friday, Palm Sunday
                                'day of week before easter
                                dt = eastR.AddDays(-1)
                                Do While dt.DayOfWeek.ToString <> parts(1)
                                    dt = dt.AddDays(-1)
                                Loop
                            End If
                        End If
                    Case s(1).Contains("last-")
                        'last-DayOfWeek-month
                        'DayOfWeek = "Monday"
                        'month = 5
                        'means last monday of may
                        dt = DateSerial(yr, Integer.Parse(parts(2)), 1)
                        dt = DateSerial(dt.Year, dt.Month, DateTime.DaysInMonth(dt.Year, dt.Month))
                        Do While dt.DayOfWeek.ToString <> parts(1)
                            dt = dt.AddDays(-1)
                        Loop
                    Case s(1).Contains("-")
                        'z-DayOfWeek-month
                        'z=1
                        'DayOfWeek = "Monday"
                        'month = 9
                        'means first monday of september
                        Dim ct As Integer = Integer.Parse(parts(0))
                        dt = DateSerial(yr, Integer.Parse(parts(2)), 1)
                        Do
                            If dt.DayOfWeek.ToString = parts(1) Then ct -= 1
                            If ct = 0 Then Exit Do
                            dt = dt.AddDays(1)
                            If dt.Year <> yr Then Stop
                        Loop
                End Select
            End If
            holidayDates.Add(DateSerial(dt.Year, dt.Month, dt.Day))
            holidayNames.Add(s(0))
        Next
    End Sub

    Public Function GetHolidayDates() As List(Of DateTime)
        Return holidayDates
    End Function

    Public Function GetHolidayNames() As List(Of String)
        Return holidayNames
    End Function

    'Holidays is an array of strings
    'the format of each string is:
    '"Holiday Name, variable"
    'Holiday Name = the name of the Holiday
    'variable:
    '1) 
    'mm/dd = the month and day of the holiday
    '2)
    'z-DayOfWeek-month
    'z=1
    'DayOfWeek = "Monday"
    'month = 9
    'means first monday of september - labor day
    '3)
    'last-DayOfWeek-month
    'DayOfWeek = "Monday"
    'month = 5
    'means last monday of may - memorial day
    '4)
    'starts with * - related to easter
    '* = Easter
    '*46 = Ash Wednesday
    '*1-Sunday-* = Palm Sunday
    '*1-Friday-*

    Dim Holidays() As String = New String() {"New Year's Day, 1/1", _
                                            "Martin Luther King Jr. Day, 3-Monday-1", _
                                            "Groundhog Day, 2/2", _
                                            "Valentine's Day, 2/14", _
                                            "Presidents Day, 3-Monday-2", _
                                            "Ash Wednesday, *46", _
                                            "St. Patrick's Day, 3/17", _
                                            "April Fools' Day, 4/1", _
                                            "Palm Sunday, *1-Sunday-*", _
                                            "Good Friday, *1-Friday-*", _
                                            "Easter Sunday, *", _
                                            "Patriot's Day, 3-Monday-4", _
                                            "Earth Day, 4/22", _
                                            "Arbor Day, last-Friday-4", _
                                            "Mother's Day, 2-Sunday-5", _
                                            "Memorial Day, last-Monday-5", _
                                            "Flag Day, 6/14", _
                                            "Father's Day, 3-Sunday-6", _
                                            "Independence Day, 7/4", _
                                            "Labor Day, 1-Monday-9", _
                                            "Columbus Day, 2-Monday-10", _
                                            "Halloween, 10/31", _
                                            "Veterans Day, 11/11", _
                                            "Thanksgiving, 4-Thursday-11", _
                                            "Pearl Harbor Remembrance Day, 12/7", _
                                            "Christmas Eve, 12/24", _
                                            "Christmas Day, 12/25", _
                                            "New Year's Eve, 12/31"}

    Dim holidayDates As New List(Of DateTime)
    Dim holidayNames As New List(Of String)
    'end of routines