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