Results 1 to 2 of 2
  1. #1
    Cybercow's Avatar
    Cybercow is offline Novice
    Windows XP Access 2003
    Join Date
    Nov 2012
    Location
    Upper MI
    Posts
    3

    Date/Time Functions

    A few years ago I found some class code and made some modifications to it. Tried to find where it was posted here before, but I was unsuccessful in locating the original post and thought it would most likely be here in the Code Archive, but I guess it was never posted in its entirety here. So, based on Allen Browne's "Returning more than one value from a function", our own Bob "raskew" generated some very handy Date & Time functions; with modifications by UA's datAdrenaline and myself.



    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 six 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".

    May you find this useful . . . .

    Code:
    Option Compare Database
    Option Explicit
    
    Dim el As Long, en As Long, ed As String
    
    Public Const conSecond = 1.15740740740741E-05 ' There are 216,000 seconds in a 24 hour period
    Public Const conMinute = 6.94444444444445E-04  ' There are 3600 minutes in a 24 hour period
    Public Const conHour = 4.16666666666667E-02  ' There are 24 hours in a 24 hour period
    
    ' and for pure date functionality: (thanks to gustav)
    Public Const cdatSecond = #00:00:01# As Date
    Public Const cdatMinute = #00:01:00# As Date
    Public Const cdatHour = #01:00:00# As Date
    
    
    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
    ' modifications by Mike Lyons (use constants instead of numerics)
    
        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
    
    'Coded by:  raskew
    
    '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
    '
    'NOTE:      Inspiration for this came from
    '           Allen Browne's site.  See: http://allenbrowne.com/ser-16.html
    '           '*******************************************
       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
    ' Written by datAdrenaline - modified by Cybercow
    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
    ' Written by Cybercow - modified by dancingwaves (Becca)
    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
    
    Public Function myGetHours(sTm As String, eTm As String)
    ' inputs can be provided as a string or date/time vartype
    ' total days:hrs:mins between two date/times
    ' if less than 24 hrs between the two dates, only hours and minutes are shown - hrs:mins
    ' if sTm or eTm are not valid date/time values, Access will throw a compile error, expecting an expression
    ' be sure to validate the sTm and eTm entries at the object level before called from an object
    
    Dim stTm As String, endTm As String, dys As String, hrs As String
    
        On Error GoTo myGetHours_Error
    
    10      If Not IsDate(sTm) Then
    20          MsgBox "The Start Date/Time provided is not a valid Date/Time value.", vbInformation + vbOKOnly, "Invalid Date Entry"
                Exit Function
    30        ElseIf Not IsDate(eTm) Then
    40          MsgBox "The End Date/Time provided is not a valid Date/Time value.", vbInformation + vbOKOnly, "Invalid Date Entry"
                Exit Function
              Else
    50          sTm = CDate(sTm)
    60          eTm = CDate(eTm)
            End If
    
    70      If (Len(sTm) > 11 Or Len(eTm) > 11) And sTm > eTm Then
    80          MsgBox "The start time cannot be greater than the end time", vbInformation + vbOKOnly, "Invalid Date Entries"
                Exit Function
            End If
                
    
    100     If IsDate(eTm) And IsDate(sTm) Then
    110         endTm = "1/2/11 " & eTm
    120         stTm = "1/1/11 " & sTm
    130         If eTm < sTm Then ' times entered traverses midnight - use date added vars
    140             myGetHours = Abs(Format(DateDiff("n", endTm, stTm) / 60, "0.00"))
    150           ElseIf eTm > sTm Then ' times entered do NOT traverse midnight - use supplied vars
    160             myGetHours = Abs(Format(DateDiff("n", eTm, sTm) / 60, "0.00"))
                  Else
    170             myGetHours = 24
                End If
              Else
    180         myGetHours = Null
            End If
    
    200     If InStr(1, eTm, ":") = 0 And InStr(1, sTm, ":") = 0 Then ' no time values in either entries - use days only
    210         myGetHours = myGetHours \ 24 & " days"
                Exit Function
            End If
    
            ' if the date differences are greater than 24 hrs, employ the dys var
    300     If Left(myGetHours, InStr(1, myGetHours, ".") - 1) > 24 Then
    310         dys = Left(myGetHours, InStr(1, myGetHours, ".") - 1) \ 24
    320         hrs = Left(myGetHours, InStr(1, myGetHours, ".") - 1) - (dys * 24)
    330         myGetHours = dys & ":" & hrs & ":" & Left(Right(myGetHours, 2) * 60, 2)
             Else
    340         myGetHours = Left(myGetHours, InStr(1, myGetHours, ".") - 1) & ":" & Left(Right(myGetHours, 2) * 60, 2)
            End If
    
    ExitProcedure:
        On Error GoTo 0
        Exit Function
    
    myGetHours_Error:
        el = Erl
        en = Err.Number
        ed = Err.Description
        MsgBox "Error " & en & " (" & ed & ") on line " & el & " in myGetHours procedure of the modDateFunctions module"
        Resume ExitProcedure
    
    End Function
    
    Public Function DateAsWords(dt As Date, Optional f As Integer = 0, Optional t As Integer = 0)
    ' Usage: DateAsWords(#1/4/2009#) or DateAsWords(#1/4/2009#,1)
    ' dt = a valid date  -   'f' selects a date format:
    ' 0 - DateAsWords(#1/4/2009#)      = "4th"
    ' 1 - DateAsWords(#1/10/2009#,3)   = "10th of January"
    ' 2 - DateAsWords(#1/24/2009#,1)   = "January 24th, 2009"
    ' 3 - DateAsWords(#1/13/2009#,2)   = "13th of January, 2009"
    '
    ' AND - 't' selects a time format:
    ' 0 - DateAsWords(#1/4/2009 10:34:23 AM#)     = "4th"  (no time displayed)
    ' 1 - DateAsWords(#1/4/2009 10:34:23 AM#,,1)  = selected date format and time in numerical format: 10:34 AM
    ' 2 - DateAsWords(#1/4/2009 10:34:23 AM#,,1)  = selected date format and time in numerical format: Ten - Thirty-Four AM
    '
    ' Make sure your date value is wrapped in #'s or is a valid date variable
    ' oterwise, you'll just get "1 divided by 4 divided by 2009" (1.24e-4)
    ' So why do simple numbers, (not even formatted like a date), return a result? . . . .
    '
    ' Access treats dates as 8 byte numbers and balances 12/30/1899
    ' as the zero point. (Dunno why) If you date format zero
    ' Format(0,"m/d/yyyy") = 12/30/1899.
    ' However, if we inadvertantly use only 3 'y's
    ' you will get: Format(0,"m/d/yyy") = 12/30/99364
    ' So, today's numeric date value is basically the number of days
    ' since 12/30/1899.
    ' The formula works negatively too. If you Format(-179,"m/d/yyyy")
    ' you will get 7/4/1899
    ' -657434 is the negative limit (1/1/100) and 2958465 is the upper
    ' limit (12/31/9999)
    Dim tm As String
    
    10        Select Case Right(Day(dt), 1)
                  Case 1
    20                DateAsWords = Day(dt) & "st"
    30            Case 2
    40                DateAsWords = Day(dt) & "nd"
    50            Case 3
    60                If Day(dt) > 9 And Day(dt) < 14 Then
    70                    DateAsWords = Day(dt) & "th"
    80                  Else
    90                    DateAsWords = Day(dt) & "rd"
                      End If
                  Case Else
    120               DateAsWords = Day(dt) & "th"
              End Select
               
    140       Select Case f
                  Case 0
                      ' Change nothing
    150           Case 1
    160               DateAsWords = DateAsWords & " of " & Format(dt, "mmmm")
    170           Case 2
    180               DateAsWords = Format(dt, "mmmm") & " " & DateAsWords & ", " & Year(dt)
    190           Case 3
    200               DateAsWords = DateAsWords & " of " & Format(dt, "mmmm") & ", " & Year(dt)
              End Select
    
    220       If Hour(dt) + Minute(dt) + Second(dt) = 0 Then
    230           tm = "Midnight"
                Else
    250           Select Case Hour(dt)
                      Case 1, 13: tm = "One"
    260               Case 2, 14: tm = "Two"
    270               Case 3, 15: tm = "Three"
    280               Case 4, 16: tm = "Four"
    290               Case 5, 17: tm = "Five"
    300               Case 6, 18: tm = "Six"
    310               Case 7, 19: tm = "Seven"
    320               Case 8, 20: tm = "Eight"
    330               Case 9, 21: tm = "Nine"
    340               Case 10, 22: tm = "Ten"
    350               Case 11, 23: tm = "Eleven"
    360               Case 12, 0: tm = "Twelve"
                  End Select
    380           Select Case Minute(dt)
                      Case Is < 11
    390                   Select Case Minute(dt)
                              Case 1: tm = tm & "-O'One"
    400                       Case 2: tm = tm & "-O'Two"
    410                       Case 3: tm = tm & "-O'Three"
    420                       Case 4: tm = tm & "-O'Four"
    430                       Case 5: tm = tm & "-O'Five"
    440                       Case 6: tm = tm & "-O'Six"
    450                       Case 7: tm = tm & "-O'Seven"
    460                       Case 8: tm = tm & "-O'Eight"
    470                       Case 9: tm = tm & "-O'Nine"
    480                       Case 10: tm = tm & "-Ten"
                          End Select
    500               Case Is < 20
    510                   Select Case Minute(dt)
                              Case 11: tm = tm & "-Eleven"
    520                       Case 12: tm = tm & "-Twelve"
    530                       Case 13: tm = tm & "-Thirteen"
    540                       Case 14: tm = tm & "-Fourteen"
    550                       Case 15: tm = tm & "-Fifteen"
    560                       Case 16: tm = tm & "-Sixteen"
    570                       Case 17: tm = tm & "-Seventeen"
    580                       Case 18: tm = tm & "-Eighteen"
    590                       Case 19: tm = tm & "-Nineteen"
                          End Select
    610               Case Is > 19
    620                   Select Case Minute(dt)
                              Case 19 To 30: tm = tm & "-Twenty"
    630                       Case 29 To 40: tm = tm & "-Thirty"
    640                       Case 39 To 50: tm = tm & "-Fourty"
    650                       Case 49 To 60: tm = tm & "-Fifty"
    660                   End Select
    670                   Select Case Right(Minute(dt), 1)
                              Case 1: tm = tm & "One"
    680                       Case 2: tm = tm & "Two"
    690                       Case 3: tm = tm & "Three"
    700                       Case 4: tm = tm & "Four"
    710                       Case 5: tm = tm & "Five"
    720                       Case 6: tm = tm & "Six"
    730                       Case 7: tm = tm & "Seven"
    740                       Case 8: tm = tm & "Eight"
    750                       Case 9: tm = tm & "Nine"
    760                       Case 0: tm = tm & ""
                          End Select
                  End Select
              End If
              
    800       Select Case t
                  Case 0
    810               DateAsWords = DateAsWords
    820           Case 1
    830               DateAsWords = DateAsWords & " - " & Format(dt, "h:nn am/pm")
    840           Case 2
    850               DateAsWords = DateAsWords & " - " & tm & " " & Format(dt, "AM/PM")
              End Select
    
    ExitProcedure:
        On Error GoTo 0
        Exit Function
    
    DateAsWords_Error:
        el = Erl
        en = Err.Number
        ed = Err.Description
        MsgBox "Error " & en & " (" & ed & ") on line " & el & " in DateAsWords procedure of the modDateFunctions module"
        Resume ExitProcedure
    
    End Function

  2. #2
    RuralGuy's Avatar
    RuralGuy is offline Administrator
    Windows 7 64bit Access 2010 32bit
    Join Date
    Mar 2007
    Location
    8300' in the Colorado Rocky Mountains
    Posts
    12,922
    Thanks Moo!

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Date functions in a query
    By ccordner in forum Queries
    Replies: 1
    Last Post: 01-27-2012, 01:45 PM
  2. Getting Just the Date part of Date/Time field
    By GaryElwood in forum Reports
    Replies: 7
    Last Post: 09-28-2011, 09:58 AM
  3. Replies: 12
    Last Post: 02-22-2011, 03:39 PM
  4. Replies: 6
    Last Post: 01-04-2011, 05:43 PM
  5. using Functions to validate a date field
    By jamin14 in forum Programming
    Replies: 1
    Last Post: 03-18-2010, 12:46 PM

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Other Forums: Microsoft Office Forums