UtterAccess HomeUtterAccess Wiki

Welcome Guest ( Log In | Register )

Custom Search
Edit Discussion
> Date/Time Functions    
CODE
' Date/Time Functions' http://www.utteraccess.com/wiki/index.php/Date/Time_Functions
' Code courtesy of UtterAccess Wiki
' Licensed under Creative Commons License
' http://creativecommons.org/licenses/by-sa/3.0/
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' rev  date        brief descripton
' 1.0  2012-09-12  In the code you'll see a couple of different versions of a "GetAge" function and
'                  a few other goodies for handling, determining and manipulating date\time values.
'                  The three constants at the top are not used specifically in the code, but are there
'                  to provide very accurate constants for 'seconds', 'minutes' and 'hours' that can be
'                  applied against a whole day value, which is "1".


Option Compare Database
Option Explicit

Public Const conSecond = 1.15740740740741E-05   ' There are 86,400 seconds in a 24 hour period (1/864,000)
Public Const conMinute = 6.94444444444445E-04   ' There are 1,440 minutes in a 24 hour period (1/1,440)
Public Const conHour = 4.16666666666667E-02     ' There are 24 hours in one day

Public Type DTS
  FirstDayOfMonth As Date           'First day of month of input date
  LastDayOfMonth As Date            'Last day of month of input date
  FirstDayOfQuarter As Date         'First day of quarter of input date
  LastDayOfQuarter As Date          'Last day of quarter of input date
  FirstDayOfPreviousMonth As Date   'First day of month prior to input date
  LastDayOfPreviousMonth As Date    'Last day of month prior to input date
  FirstDayOfNextMonth As Date       'First day of month following input date
  LastDayOfNextMonth As Date        'Last day of month following input date
  FirstDayOfPreviousQuarter As Date 'First day of quarter prior to input date
  LastDayOfPreviousQuarter As Date  'Last day of quarter prior to input date
  FirstDayOfNextQuarter As Date     'First day of next quarter following input date
  LastDayOfNextQuarter As Date      'Last day of next quarter following input date
  NextWorkDay As Date               'Next workday (Mon - Fri) following input date
  PreviousWorkDay As Date           'Previous workday (Mon - Fri) before input date
  IsLeapYear As Boolean             'Input date falls in a leap year
  IsWeekDay As Boolean              'Input date is a workday (Mon - Fri)
  NextNDay As Date                  'First day of week (Sun:1 to Sat:7) following input date
  LastNDay As Date                  'Last day of week (Sun:1 to Sat: 7) prior to input date
  WeekStartDate As Date             'Display start date week in which input date falls
  DayOfYear As Integer              'Day of year of input date (1 - 366)
  DateDiffYears As Long             'Number of years between two dates
  DateDiffMonths As Long            'Number of months between two dates
  DateDiffDays As Long              'Number of days between two dates
  DateDiffHours As Long             'Number of hours between two dates
  DateDiffMins As Long              'Number of minutes between two dates
  DateDiffSecs As Double            'Number of seconds between two dates
 
End Type


Public Function myIsWeekend(chDate As Date) As Boolean

   If WeekDay(chDate) = vbSunday Or WeekDay(chDate) = vbSaturday Then
       myIsWeekend = True
     Else
       myIsWeekend = False
   End If

End Function

Public Function myIsEOM(chDate As Date) As Boolean

   If DateSerial(Year(chDate), Month(chDate), Day(chDate)) = DateSerial(Year(chDate), Month(chDate) + 1, 0) Then
       myIsEOM = True
     Else
       myIsEOM = False
   End If

End Function

Public Function IsLeapYear(intYear As Integer) As Boolean
' Comments : determine if the year is a leap year using Access functions
' Parameters: intYear - integer year
' Returns : True - year is a leap year, False otherwise
'
IsLeapYear = Month(DateSerial(intYear, 2, 29)) = 2
' Returning more than one value from a function

End Function

Function GetDTS(ByVal dteMyDate As Variant, Optional ByVal dte2 As Date, _
               Optional ByVal myInt As Integer) As DTS

'*******************************************
'Purpose:   Returns common date calculations

'Inputs:    from debug window:
'           (1) ? getDTS(#6/5/03#).FirstDayOfPreviousQuarter
'           (2) ? getDTS(#6/6/03#).NextWorkDay
'           (3) ? getDTS(#4/25/03#,, 2).WeekStartDate
'
'Output:    (1) 1/1/2003
'           (2) 6/9/2003
'           (3) 4/21/03
'
'*******************************************
  With GetDTS
       .FirstDayOfMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]), 1)
       .LastDayOfMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]) + 1, 0)
       .FirstDayOfQuarter = DateSerial(Year([dteMyDate]), _
                            3 * Int(((Month([dteMyDate])) - 1) / 3) + 1, 1)
       .LastDayOfQuarter = DateSerial(Year([dteMyDate]), 3 * Int((Month([dteMyDate]) - 1) / 3) + 4, 0)
       .FirstDayOfPreviousMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]) - 1, 1)
       .LastDayOfPreviousMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]), 0)
       .FirstDayOfNextMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]) + 1, 1)
       .LastDayOfNextMonth = DateSerial(Year([dteMyDate]), Month([dteMyDate]) + 2, 0)
       .FirstDayOfPreviousQuarter = DateSerial(Year([dteMyDate]), _
                                    3 * Int(((Month([dteMyDate])) - 1) / 3) - 2, 1)
       .LastDayOfPreviousQuarter = DateSerial(Year([dteMyDate]), _
                                   3 * Int(((Month([dteMyDate])) - 1) / 3) + 1, 1) - 1
       .FirstDayOfNextQuarter = DateSerial(Year([dteMyDate]), _
                                3 * Int(((Month([dteMyDate])) - 1) / 3) + 4, 1)
       .LastDayOfNextQuarter = DateSerial(Year([dteMyDate]), _
                                3 * Int(((Month([dteMyDate])) - 1) / 3) + 7, 1) - 1
       .NextWorkDay = [dteMyDate] + IIf(WeekDay([dteMyDate]) > 5, 9 - WeekDay([dteMyDate]), 1)
       .PreviousWorkDay = [dteMyDate] - IIf(WeekDay([dteMyDate]) < 3, 1 + WeekDay([dteMyDate]), 1)
       .IsLeapYear = IIf(Year([dteMyDate]) Mod 100 = 0, _
                     IIf(Year([dteMyDate]) Mod 400 = 0, True, False), _
                     IIf(Year([dteMyDate]) Mod 4 = 0, True, False))
       .IsWeekDay = IIf(WeekDay([dteMyDate], 1) > 6 Or WeekDay([dteMyDate], 1) = 1, False, True)
       .NextNDay = [dteMyDate] - WeekDay([dteMyDate]) + myInt + IIf(WeekDay([dteMyDate]) >= myInt, 7, 0)
       .LastNDay = [dteMyDate] - (WeekDay([dteMyDate]) + IIf(WeekDay([dteMyDate]) <= myInt, 7, 0) - myInt)
       .WeekStartDate = IIf(WeekDay(dteMyDate) = myInt, dteMyDate, _
                        dteMyDate - (WeekDay(dteMyDate) + _
                        IIf(WeekDay(dteMyDate) <= myInt, 7, 0) - myInt))
       .DayOfYear = Val(Format(dteMyDate - DateSerial(Year(dteMyDate) - 1, 12, 31), "000"))
       .DateDiffYears = DateDiff("yyyy", dteMyDate, dte2) + _
                       (dte2 < DateSerial(Year(dte2), Month(dteMyDate), Day(dteMyDate)))
       .DateDiffMonths = DateDiff("m", dteMyDate, dte2) + (Day(dteMyDate) > Day(dte2))
       .DateDiffDays = DateDiff("d", dteMyDate, dte2) + (Hour(dteMyDate) > Hour(dte2))
       .DateDiffHours = DateDiff("h", dteMyDate, dte2) + (Minute(dteMyDate) > Minute(dte2))
       .DateDiffMins = DateDiff("n", dteMyDate, dte2) + (Second(dteMyDate) > Second(dte2))
       .DateDiffSecs = DateDiff("s", dteMyDate, dte2)
   End With

End Function

Public Function myGetAge(ByVal bDate As Date) As String
Dim strTemp As String, dtTemp As Date
Dim yrs As Long, mos As Long, dys As Long
Dim dblTotalTime As Double
Dim X As Integer
   
   'Ensure the start is LESS than the stop
   If bDate > Date Then
       MsgBox "No date greater than today is allowed.", vbOKOnly + vbInformation, "Unacceptable Date"
       Exit Function
   End If
   
   'Get the years between the two dates
   yrs = DateDiff("yyyy", bDate, Date)
   yrs = yrs - Abs(DateAdd("yyyy", yrs, bDate) > Date)
   
   'Get the months between the two dates that exceed the years
   mos = DateDiff("m", bDate, Date)
   mos = mos - Abs(DateAdd("m", mos, bDate) > Date) - (yrs * 12)
   
   'Get the number of days between the two dates that exceed the years + months ...
   dys = DateDiff("n", DateAdd("m", mos + yrs * 12, bDate), Date) \ 1440
   
   'Build string for the "left" half of our time difference
   For X = 1 To 3
       strTemp = strTemp & "|" & Choose(X, yrs, mos, dys) & " " & Choose(X, "yrs", "mos", "dys")
   Next X
   
   'Return the string
   myGetAge = mid(strTemp, 2)
   
End Function

Public Function myAge(dteDate As Date) As String
Dim intYears As Integer
Dim intMonths As Integer
Dim intDays As Integer

   'Make sure the date provided is past date
       If dteDate <= Date Then
       
       'Determine the number of years between the date provided and the current date
       intYears = DateDiff("yyyy", dteDate, Date)
       
       'Determine the number of months between the date provided and the current date using the current year
       'as part of the from date to only return months
       intMonths = DateDiff("m", DateSerial(Year(Date), Month(dteDate), Day(dteDate)), Date)
MonthsCalc:
       'If the months returned are less then 0, subtract 1 from the year calculation and redo the months calculation
       'subtracting one from the current year
       If intMonths < 0 Then
           intYears = intYears - 1
           intMonths = DateDiff("m", DateSerial(Year(Date) - 1, Month(dteDate), Day(dteDate)), Date)
       End If
       
       'Determine the number of days between the date provided and the current date using the current year
       'and current month as part of the from date to only return days
       intDays = DateDiff("d", DateSerial(Year(Date), Month(Date), Day(dteDate)), Date)
       'if the days returned are less then 0, subtract 1 from the month calculation and redo the days calculation
       'subtracting one from the current month.
       If intDays < 0 Then
           intMonths = intMonths - 1
           'test to see if resulting intMonths is <0.  If so, recalculate months.
           If intMonths < 0 Then
               GoTo MonthsCalc
           End If
           intDays = DateDiff("d", DateSerial(Year(Date), Month(Date) - 1, Day(dteDate)), Date)
       End If
       
       'Assemble the return string
       myAge = intYears & " Years, " & intMonths & " Months, " & intDays & " Days."
     Else
       'If the date provided is in the future, return Negative Age
       myAge = "Negative Age"
   End If

End Function

The attachment below is just the zipped text file version of the code above.

Date-Time_Functions

Creative Commons License
Date/Time Functions by UtterAccess Wiki is licensed under a Creative Commons Attribution-ShareAlike 3.0 Unported License.
Editing and revision of the content is freely encouraged; for details, see Expected Usage.

Edit Discussion
Custom Search
Thank you for your support!
This page has been accessed 12,389 times.  This page was last modified 16:57, 22 September 2013 by Mark Davis.   Disclaimers