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