I have a Visiting db at my prison. Visiting days are Fri., Sat., Sun., Mon. We are closed Tues., Wed., and Thurs.. The database is set up to reset the visiting lists on Mon., but our Visiting week runs Fri-Mon, and we need to keep a running list of visits through those four days. Then we need it to reset on Wed. I've been in the code, and found the dhFirstdayofweek string, which was set to +1, and set that to +3 which I thought was Wed. It worked Saturday, but come Monday it wouldn't keep track of the visits at all. Am I missing something?
Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
How do you change the start of the workweek?
- Thread starter hitman74
- Start date
You will probably have to post some code. I am not sure what function that constant is from. Is that an API or custom function constant. If dhFirstDayOfWeek constants corresponds with vb dayofweek constants then
vbWednesday is 4
vbUseSystem 0 Use National Language Support (NLS) API setting.
vbSunday 1 Sunday (default)
vbMonday 2 Monday
vbTuesday 3 Tuesday
vbWednesday 4 Wednesday
vbWednesday is 4
vbUseSystem 0 Use National Language Support (NLS) API setting.
vbSunday 1 Sunday (default)
vbMonday 2 Monday
vbTuesday 3 Tuesday
vbWednesday 4 Wednesday
- Thread starter
- #3
This is from the basDateTime module I'm trying to edit:
Code:
Option Compare Database
Option Explicit
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
(ByVal lpAppName As String, ByVal lpKeyName As String, _
ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Function dhIsLeapYear(Optional varDate As Variant) As Boolean
' Is the supplied year a leap year?
' Check the day number of the day
' after Feb 28 to find out.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' varDate (Optional):
' If unspecified, use the current year.
' If a date, use the year of the specified date.
' If a valid integer (between 100 and 9999),
' use that value as the year, otherwise use the current year.
' If any other dtma type, act as if varDate wasn't specified
' (that is, use the current year).
' Out:
' Return value:
' Boolean indicating whether the specified year
' is a leap year.
' Example:
' If dhIsLeapYear() Then
' ' You know the current year is a leap year.
'
' If dhIsLeapYear(1956) Then
' ' You know 1956 was a leap year.
'
' If dhIsLeapYear(#12/1/92#) Then
' ' You know 1992 was a leap year.
' Missing? Use the current year.
If IsMissing(varDate) Then
varDate = Year(Now)
' Is it a date? Then use that year.
ElseIf VarType(varDate) = vbDate Then
varDate = Year(varDate)
' Is it an integer? Use that value, if it's value.
' Otherwise, use the current year.
ElseIf VarType(varDate) = vbInteger Then
' Only years 100 through 9999 are allowed.
If varDate < 100 Or varDate > 9999 Then
varDate = Year(Now)
End If
' If it's not a date or an integer, just use the
' current year.
Else
varDate = Year(Now)
End If
dhIsLeapYear = (Day(DateSerial(varDate, 2, 28) + 1) = 29)
End Function
Function dhPreviousDOW(intDOW As Integer, Optional dtmDate As Date = 0) As Date
' Find the previous specified day of week before the specified date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' intDOW:
' The day of the week (vbSunday (1) through
' vbSaturday (7)) to search for.
' dtmDate:
' The starting date.
' Use the current date, if none was specified.
' Out:
' Return Value:
' date representing the prior occurrence of the specified day of week
' before dtmDate. If dtmDate falls on intDOW, returns dtmDate.
' Example:
' dbFindPreviousdate(#5/1/97#, 1) returns the Sunday prior to 5/1/9
' (that is, 4/27/97).
Dim intTemp As Integer
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
intTemp = Weekday(dtmDate)
dhPreviousDOW = dtmDate - intTemp + intDOW - IIf(intTemp > intDOW, 0, 7)
End Function
Function dhNextDOW(intDOW As Integer, Optional dtmDate As Date = 0) As Date
' Find the next specified day of week after the specified date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' intDOW:
' The day of the week (vbSunday (1) through
' vbSaturday (7)) to search for.
' dtmDate:
' The starting date.
' Use the current date, if none was specified.
' Out:
' Return Value:
' date representing the next occurrence of the specified day of week
' after dtmDate. If dtmDate falls on intDOW, returns dtmDate.
' Example:
' dbFindNextdate(#5/1/97#, 1) returns the Sunday after 5/1/9
' (that is, 5/4/97).
Dim intTemp As Integer
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
intTemp = Weekday(dtmDate)
dhNextDOW = dtmDate - intTemp + intDOW + IIf(intTemp < intDOW, 0, 7)
End Function
Function dhNextAnniversary(dtmDate As Date) As Date
' Given a date, find the next anniversary of that date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' A date representing a birthdate or anniversary.
' Out:
' Return Value:
' The next occurence of the specified date. If the date hasn't
' occurred yet this year, return the date within the
' current year. Otherwise, return the date in the next
' year.
' Example:
' If the current date is 11/15/97,
' dhNextAnniversary(#5/16/56#) will return 5/16/98, the
' next time the anniversary occurs.
Dim dtmThisYear As Date
' What's the corresponding date in the current year?
dtmThisYear = DateSerial(Year(Now), Month(dtmDate), Day(dtmDate))
' If the anniversary has already occurred, then add 1 to the year.
If dtmThisYear < Date Then
dtmThisYear = DateAdd("yyyy", 1, dtmThisYear)
End If
dhNextAnniversary = dtmThisYear
End Function
Function dhFirstDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the first day in the specified month.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' The specified date.
' Use the current date, if none was specified.
' Out:
' Return Value:
' The date of the first day in the specified month.
' Example:
' dhFirstDayInMonth(#5/7/70#) returns 5/1/70.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhFirstDayInMonth = DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
Function dhLastDayInMonth(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified month.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' The specified date
' Use the current date, if none was specified.
' Out:
' Return Value:
' The date of the last day in the specified month.
' Comments:
' This function counts on odd behavior of dateSerial. That is, each of the
' numeric values can be an expression containing a relative value. Here, the
' Day value becomes 1 - 1 (that is, the day before the first day of the month).
' Example:
' dhLastDayInMonth(#5/7/70#) returns 5/1/70.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
End Function
Function dhFirstDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the first day in the week specified by the date in dtmDate.
' Uses localized settings for the first day of the week.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date specifying the week in which to work.
' Use the current date, if none was specified.
' Out:
' Return Value:
' First day of the specified week, taking into account the
' user's locale.
' Example:
' dhFirstDayInWeek(#4/1/97#) returns 3/30/97 in the US.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhFirstDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 1
End Function
Function dhLastDayInWeek(Optional dtmDate As Date = 0) As Date
' Returns the last day in the week specified by the date in dtmDate.
' Uses localized settings for the first day of the week.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date specifying the week in which to work.
' Use the current date, if none was specified.
' Out:
' Return Value:
' Last day of the specified week, taking into account the
' user's locale.
' Example:
' dhLastDayInWeek(#4/1/97#) returns 4/5/97 in the US.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInWeek = dtmDate - Weekday(dtmDate, vbUseSystem) + 7
End Function
Function dhFirstDayInQuarter(Optional dtmDate As Date = 0) As Date
' Returns the first day in the quarter specified by the date in dtmDate.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date specifying the quarter in which to work.
' Use the current date, if none was specified.
' Out:
' Return Value:
' First day of the specified quarter.
' Example:
' dhFirstDayInQuarter(#4/15/97#) returns 4/1/97.
Const dhcMonthsInQuarter As Integer = 3
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhFirstDayInQuarter = DateSerial( _
Year(dtmDate), _
Int((Month(dtmDate) - 1) / dhcMonthsInQuarter) _
* dhcMonthsInQuarter + 1, _
1)
End Function
Function dhLastDayInQuarter(Optional dtmDate As Date = 0) As Date
' Returns the last day in the quarter specified by the date in dtmDate.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date specifying the quarter in which to work.
' Use the current date, if none was specified.
' Out:
' Return Value:
' Last day of the specified quarter.
' Example:
' dhLastDayInQuarter(#4/1/97#) returns 6/30/97.
Const dhcMonthsInQuarter As Integer = 3
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInQuarter = DateSerial( _
Year(dtmDate), _
Int((Month(dtmDate) - 1) / dhcMonthsInQuarter) _
* dhcMonthsInQuarter + (dhcMonthsInQuarter + 1), _
0)
End Function
Function dhFirstDayInYear(Optional dtmDate As Date = 0) As Date
' Return the first day in the specified year.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' The specified date
' Use the current date, if none was specified.
' Out:
' Return Value:
' The date of the first day in the specified year.
' Example:
' dhFirstDayInYear(#5/7/70#) returns 12/31/70.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhFirstDayInYear = DateSerial(Year(dtmDate), 1, 1)
End Function
Function dhLastDayInYear(Optional dtmDate As Date = 0) As Date
' Return the last day in the specified year.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate (Optional)
' The specified date
' Use the current date, if none was specified.
' Out:
' Return Value:
' The date of the last day in the specified year.
' Example:
' dhLastDayInYear(#5/7/70#) returns 12/31/70.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhLastDayInYear = DateSerial(Year(dtmDate), 12, 31)
End Function
Function dhFirstWorkdayInMonth(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, Optional strField As String = "") As Date
' Return the first working day in the month specified.
' If you want to look up holidays in a table, pass in
' a DAO recordset object containing the rows.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date within the month of interest.
' Use the current date, if none was specified.
' rst (Optional):
' Reference to an open dynaset-type recordset containing
' information about the holidays for the year in question.
' If you supply this value, you must also supply
' strField, the name of the field containing date information.
' strField (Optional):
' If you supply rst, you must supply this parameter, the
' name of the field in rst containing information about
' the holidays.
' Out:
' Return Value:
' The date of the first working day in the month, taking
' into account weekends and holidays.
' Example:
' ' To find the first working day in 1997, given
' ' a table named tblHolidays in a Jet Database named
' ' Holidays. This table contains a column named date,
' ' containing the Holiday date information.
' Dim db As Database
' Dim rst As Recordset
' Set db = DBEngine.OpenDatabase("Holidays.MDB")
' Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
' dtmDate = dhFirstWorkdayInMonth(#1/1/97#, rst, "date")
Dim dtmTemp As Date
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
dhFirstWorkdayInMonth = SkipHolidays(rst, strField, dtmTemp, 1)
End Function
Function dhLastWorkdayInMonth(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, Optional strField As String = "") As Date
' Return the last working day in the month specified.
' If you want to look up holidays in a table, pass in
' a DAO recordset object containing the rows.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date within the month of interest.
' Use the current date, if none was specified.
' rst (Optional):
' Reference to an open dynaset-type recordset containing
' information about the holidays for the year in question.
' If you supply this value, you must also supply
' strField, the name of the field containing date information.
' strField (Optional):
' If you supply rst, you must supply this parameter, the
' name of the field in rst containing information about
' the holidays.
' Out:
' Return Value:
' The date of the last working day in the month, taking
' into account weekends and holidays.
' Example:
' ' To find the last working day in 1997, given
' ' a table named tblHolidays in a Jet Database named
' ' Holidays. This table contains a column named date,
' ' containing the Holiday date information.
' Dim db As Database
' Dim rst As Recordset
' Set db = DBEngine.OpenDatabase("Holidays.MDB")
' Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
' dtmDate = dhLastWorkdayInMonth(#12/31/97#, rst, "date")
Dim dtmTemp As Date
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
dhLastWorkdayInMonth = SkipHolidays(rst, strField, dtmTemp, -1)
End Function
Function dhNextWorkday(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, Optional strField As String = "") As Date
' Return the next working day after the specified date.
' If you want to look up holidays in a table, pass in
' a DAO recordset object containing the rows.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' rst (Optional):
' Reference to an open dynaset-type recordset containing
' information about the holidays for the year in question.
' If you supply this value, you must also supply
' strField, the name of the field containing date information.
' strField (Optional):
' If you supply rst, you must supply this parameter, the
' name of the field in rst containing information about
' the holidays.
' Out:
' Return Value:
' The date of the next working day, taking
' into account weekends and holidays.
' Example:
' ' Find the next working date after 5/30/97, given
' ' a table named tblHolidays in a Jet Database named
' ' Holidays. This table contains a column named date,
' ' containing the Holiday date information.
' Dim db As Database
' Dim rst As Recordset
' Set db = DBEngine.OpenDatabase("Holidays.MDB")
' Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
' dtmDate = dhNextWorkday(#5/23/97#, rst, "date")
' ' dtmDate should be 5/27/97, because 5/26/97 is Memorial day.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhNextWorkday = SkipHolidays(rst, strField, dtmDate + 1, 1)
End Function
Function dhPreviousWorkday(Optional dtmDate As Date = 0, _
Optional rst As Recordset = Nothing, Optional strField As String = "") As Date
' Return the previous working day before the specified date.
' If you want to look up holidays in a table, pass in
' a DAO recordset object containing the rows.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' IsWeekend
' In:
' dtmDate:
' date on which to start looking.
' Use the current date, if none was specified.
' rst (Optional):
' Reference to an open dynaset-type recordset containing
' information about the holidays for the year in question.
' If you supply this value, you must also supply
' strField, the name of the field containing date information.
' strField (Optional):
' If you supply rst, you must supply this parameter, the
' name of the field in rst containing information about
' the holidays.
' Out:
' Return Value:
' The date of the previous working day, taking
' into account weekends and holidays.
' Example:
' ' Find the previous working date before 5/27/97, given
' ' a table named tblHolidays in a Jet Database named
' ' Holidays. This table contains a column named date,
' ' containing the Holiday date information.
' Dim db As Database
' Dim rst As Recordset
' Set db = DBEngine.OpenDatabase("Holidays.MDB")
' Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
' dtmDate = dhPreviousWorkday(#5/27/97#, rst, "date")
' ' dtmDate should be 5/23/97, because 5/26/97 is Memorial day.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhPreviousWorkday = SkipHolidays(rst, strField, dtmDate - 1, -1)
End Function
Function dhCountWorkdays(ByVal dtmStart As Date, ByVal dtmEnd As Date, _
Optional rst As Recordset = Nothing, Optional strField As String = "") _
As Integer
' Count the business days (not counting weekends/holidays) in
' a given date range.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' SkipHolidays
' CountHolidays
' IsWeekend
' In:
' dteStart:
' Date specifying the start of the range
' dteEnd:
' Date specifying the end of the range
' (dates will be swapped if out of order)
' rst (Optional):
' Reference to an open dynaset-type recordset containing
' information about the holidays for the year in question.
' If you supply this value, you must also supply
' strField, the name of the field containing date information.
' strField (Optional):
' If you supply rst, you must supply this parameter, the
' name of the field in rst containing information about
' the holidays.
' Out:
' Return Value:
' Number of working days (not counting weekends and optionally, holidays)
' in the specified range.
' Example:
' Dim rst As Recordset
' Dim db As Database
' Set db = DBEngine.OpenDatabase("Holidays.MDB")
' Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
' Debug.Print dhCountWorkdays(#12/27/96#, #1/2/97#, rst, "Date")
' ' Returns 3, if 12/31 and 1/1 are holidays
' Debug.Print dhCountWorkdays(#12/27/96#, #1/1/97#)
' ' Returns 5, because the code skips weekends only, and doesn't
' ' consider holidays.
Dim intDays As Integer
Dim dtmTemp As Date
Dim intSubtract As Integer
' Swap the dates if necessary.
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If
' Get the start and end dates to be weekdays.
dtmStart = SkipHolidays(rst, strField, dtmStart, 1)
dtmEnd = SkipHolidays(rst, strField, dtmEnd, -1)
If dtmStart > dtmEnd Then
' Sorry, no Workdays to be had. Just return 0.
dhCountWorkdays = 0
Else
intDays = dtmEnd - dtmStart + 1
' Subtract off weekend days. We do this by figuring out how many
' calendar weeks there are between the dates, and multiplying the
' difference by two (since there are two weekend days for each week).
' That is, if the difference is 0, the two days are in the same week.
' If the difference is 1, then we have two weekend days.
intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2)
' The answer to our quest is all the weekdays, minus any
' holidays found in the table.
' If rst is Nothing, this call won't subtract any dates.
intSubtract = intSubtract + CountHolidays(rst, strField, _
dtmStart, dtmEnd)
dhCountWorkdays = intDays - intSubtract
End If
End Function
Function dhNthWeekday(dtmDate As Date, intN As Integer, _
intDOW As Integer) As Date
' Find the date of the specified day within the month. For
' example, retrieve the 3rd Tuesday's date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' Starting date for the search. If this isn't the first
' day of the month, the code moves back to the first.
' intN:
' Number of the specific day, within the month. If larger
' than there are days of the specified type in the month,
' return the date of the requested day anyway. If you ask for
' the 10th Monday, the code will just find the first Monday
' in the specified month, and then add 10 weeks to that date.
' intDOW:
' Day of the week to seek.
' Out:
' Return Value:
' The date of the nth specified day after the first day of the
' the specified month.
' Example:
' dhNthWeekday(#5/5/97#, 3, 3) returns the third Tuesday in 5/97,
' that is, #5/20/97#.
Dim dtmTemp As Date
If (intDOW < vbSunday Or intDOW > vbSaturday) _
Or (intN < 1) Then
' Invalid parameter values. Just
' return the passed-in date.
dhNthWeekday = dtmDate
Exit Function
End If
' Get the first of the month.
dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
' Get to the first intDOW in the month.
Do While Weekday(dtmTemp) <> intDOW
dtmTemp = dtmTemp + 1
Loop
' Now you've found the first intDOW in the month.
' Just add 7 for each intN after that.
dhNthWeekday = dtmTemp + ((intN - 1) * 7)
End Function
Private Function CountHolidays(rst As Recordset, strField As String, _
dtmStart As Date, datend As Date) As Integer
' Count holidays between two end dates.
'
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Required by:
' dhCountWorkdays
Dim rstNew As Recordset
Dim strFilter As String
Dim strOldFilter As String
Dim intRows As Integer
On Error GoTo HandleErr
If Not rst Is Nothing Then
If Len(strField) > 0 Then
If Left(strField, 1) <> "[" Then
strField = "[" & strField & "]"
End If
strFilter = strField & " BETWEEN #" & dtmStart & "# AND #" & datend & "#"
strOldFilter = rst.Filter
rst.Filter = strFilter
Set rstNew = rst.OpenRecordset()
If rstNew.RecordCount > 0 Then
rstNew.MoveLast
intRows = rstNew.RecordCount
End If
rstNew.Close
End If
End If
ExitHere:
CountHolidays = intRows
Exit Function
HandleErr:
' No matter what the error, just
' return without complaining.
' The worst that could happen is that the code
' include a holiday as a real day, even if
' it's in the table.
Resume ExitHere
End Function
Private Function SkipHolidays(rst As Recordset, _
strField As String, dtmTemp As Date, intIncrement As Integer) As Date
' Skip weekend days, and holidays in the recordset referred to by rst.
' Return dtmTemp + as many days as it takes to get to a day that's not
' a holiday or weekend.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Required by:
' dhFirstWorkdayInMonth
' dbLastWorkdayInMonth
' dhNextWorkday
' dhPreviousWorkday
' dhCountWorkdays
Dim strCriteria As String
On Error GoTo HandleErr
' Move up to the first Monday/last Friday, if the first/last
' of the month was a weekend date. Then skip holidays.
' Repeat this entire process until you get to a weekday.
' Unless rst contains a row for every day in the year (!)
' this should finally converge on a weekday.
Do
Do While IsWeekend(dtmTemp)
dtmTemp = dtmTemp + intIncrement
Loop
If Not rst Is Nothing Then
If Len(strField) > 0 Then
If Left(strField, 1) <> "[" Then
strField = "[" & strField & "]"
End If
Do
strCriteria = strField & " = #" & Format(dtmTemp, "mm/dd/yy") & "#"
rst.FindFirst strCriteria
If Not rst.NoMatch Then
dtmTemp = dtmTemp + intIncrement
End If
Loop Until rst.NoMatch
End If
End If
Loop Until Not IsWeekend(dtmTemp)
ExitHere:
SkipHolidays = dtmTemp
Exit Function
HandleErr:
' No matter what the error, just
' return without complaining.
' The worst that could happen is that we
' include a holiday as a real day, even if
' it's in the table.
Resume ExitHere
End Function
Private Function IsWeekend(dtmTemp As Date) As Boolean
' If your weekends aren't Saturday (day 7) and Sunday (day 1),
' change this routine to return True for whatever days
' you DO treat as weekend days.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Required by:
' SkipHolidays
' dhFirstWorkdayInMonth
' dbLastWorkdayInMonth
' dhNextWorkday
' dhPreviousWorkday
' dhCountWorkdays
Select Case Weekday(dtmTemp)
Case vbSaturday, vbSunday
IsWeekend = True
Case Else
IsWeekend = False
End Select
End Function
Sub TestCountWorkdays()
Dim rst As DAO.Recordset
Dim db As DAO.Database
' You'll need to modify the path in the next line, to point
' to your sample database.
Set db = DAO.DBEngine.OpenDatabase("HOLIDAYS.MDB")
Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
Debug.Print dhCountWorkdays(#12/27/1996#, #1/2/1997#, rst, "Date")
Debug.Print dhCountWorkdays(#12/27/1996#, #1/2/1997#)
End Sub
Sub TestSkipHolidays()
Dim rst As DAO.Recordset
Dim db As DAO.Database
' You'll need to modify the path in the next line, to point
' to your sample database.
Set db = DAO.DBEngine.OpenDatabase("HOLIDAYS.MDB")
Set rst = db.OpenRecordset("tblHolidays", DAO.dbOpenDynaset)
Debug.Print dhFirstWorkdayInMonth(#1/1/1997#, rst, "date")
Debug.Print dhLastWorkdayInMonth(#12/31/1997#, rst, "date")
Debug.Print dhNextWorkday(#5/23/1997#, rst, "date")
Debug.Print dhNextWorkday(#5/27/1997#, rst, "date")
Debug.Print dhPreviousWorkday(#5/27/1997#, rst, "date")
Debug.Print dhPreviousWorkday(#5/23/1997#, rst, "date")
End Sub
Function dhCNumdate(ByVal lngdate As Long, _
ByVal strFormat As String) As Variant
' Convert numbers to dates, depending on the specified format
' and the incoming number. In this case, the number and the
' format must match, or the output will be useless.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' lngdate:
' Number representing the date to be returned. Because numbers don't
' have leading 0's, that sitation will never occur.
' strFormat:
' String expression containing the format of the value in lngdate.
' Must be one of the following:
' "MMDDYY"'
' "MMDDYYYY"
' "DDMMYY"
' "DDMMYYYY"
' "YYMMDD"
' "YYYYMMDD"
' Out:
' The value in lngdate, converted to a date, given the format specified
' in strFormat.
' Example:
' dhCNumdate(19560516, "YYYYMMDD") will return the date 5/16/56.
' dhCNumdate(51656, "MMDDYY") will return the date 5/16/56
' dhCNumdate(51620, "MMDDYY") will return the date 5/16/2020
Dim intYear As Integer
Dim intMonth As Integer
Dim intDay As Integer
Dim fOk As Boolean
fOk = True
Select Case strFormat
Case "MMDDYY"
intYear = lngdate Mod 100
intMonth = lngdate \ 10000
intDay = (lngdate \ 100) Mod 100
Case "MMDDYYYY"
intYear = lngdate Mod 10000
intMonth = lngdate \ 1000000
intDay = (lngdate \ 10000) Mod 100
Case "DDMMYY"
intYear = lngdate Mod 100
intMonth = (lngdate \ 100) Mod 100
intDay = lngdate \ 10000
Case "DDMMYYYY"
intYear = lngdate Mod 10000
intMonth = (lngdate \ 10000) Mod 100
intDay = lngdate \ 1000000
Case "YYMMDD", "YYYYMMDD"
intYear = lngdate \ 10000
intMonth = (lngdate \ 100) Mod 100
intDay = lngdate Mod 100
Case Else
fOk = False
End Select
If fOk Then
dhCNumdate = DateSerial(intYear, intMonth, intDay)
Else
dhCNumdate = Null
End If
End Function
Function dhCStrdate(strDate As String, Optional strFormat As String = "") As Date
' Given a string containing a date value, and a format
' string describing the information in the date string,
' convert the string into a real date value.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' strDate:
' String expression containing a date to be converted.
' strFormat (Optional):
' String expression containing a format specifier for the
' string in strdate. If omitted, the function uses "", which
' will cause it to use the Cdate function to attempt to
' conversion, just as it will if any other unknown format
' string is passed in.
'
' Allowable formats:
' "MMDDYY", "MMDDYYYY"
' "DDMMYY", "DDMMYYYY"
' "YYMMDD", "YYYYMMDD"
' "DD/MM/YY", "DD/MM/YYYY" ("/" stands for any delimiter in the date string)
' "YY/MM/DD", "YYYY/MM/DD"
' Out:
' Return Value:
' The value in strDate, converted to a date, if possible.
' Example:
' dhCStrdate("59/04/22", "YY/MM/DD") returns the real date #4/22/59#
'
Dim strYear As String
Dim strMonth As String
Dim strDay As String
Dim fDone As Boolean
Select Case strFormat
Case "MMDDYY", "MMDDYYYY"
strYear = Mid(strDate, 5)
strMonth = Left(strDate, 2)
strDay = Mid(strDate, 3, 2)
Case "DDMMYY", "DDMMYYYY"
strYear = Mid(strDate, 5)
strMonth = Mid(strDate, 3, 2)
strDay = Left(strDate, 2)
Case "YYMMDD"
strYear = Left(strDate, 2)
strMonth = Mid(strDate, 3, 2)
strDay = Right(strDate, 2)
Case "YYYYMMDD"
strYear = Left(strDate, 4)
strMonth = Mid(strDate, 5, 2)
strDay = Right(strDate, 2)
Case "DD/MM/YY", "DD/MM/YYYY"
strYear = Mid(strDate, 7)
strMonth = Mid(strDate, 4, 2)
strDay = Left(strDate, 2)
Case "YY/MM/DD"
strYear = Left(strDate, 2)
strMonth = Mid(strDate, 4, 2)
strDay = Right(strDate, 2)
Case "YYYY/MM/DD"
strYear = Left(strDate, 4)
strMonth = Mid(strDate, 6, 2)
strDay = Right(strDate, 2)
Case Else
' If none of the other formats were matched, just count on Cdate
' to do the conversion. It may fail, but we can't help out here.
dhCStrdate = CDate(strDate)
fDone = True
End Select
If Not fDone Then
dhCStrdate = DateSerial(Val(strYear), Val(strMonth), Val(strDay))
End If
End Function
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
' Return the number of days in the specified month.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date within the month in which you need the number of days.
' Use the current date, if none was specified.
' Out:
' Return Value:
' Number of days in the specified month.
' Example:
' dhDaysInMonth(#2/1/96#) returns 29.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhDaysInMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 1) - _
DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
Function dhCountDOWInMonth(ByVal dtmDate As Date, _
Optional intDOW As Integer = 0) As Integer
' Calculate the number of specified days in
' the specified month.
'
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
'
' In:
' dtmDate:
' date value specifying the month and year
' If intDOW is missing, this date also
' supplies the day of week to count.
' intDOW: (Optional)
' If supplied, contains the day of week
' (vbSunday (1) - vbSaturday (7)) to be
' counted within the specified month/year.
' If not supplied, the function uses the
' day of week of the required date parameter.
' Out:
' Return value:
' The number of days matching intDOW (or dtmDate)
' in the specified month/year.
'
' Example:
' dhCountDOWInMonth(#11/96#, 6) returns 5
' (there were 5 Fridays in November 1996)
' dhCountDOWInMonth(#11/3/96#) returns 4
' (11/3/96 was a Sunday, and there were 4 Sundays in the month)
' dhCountDOWInMonth(#11/3/96#, 6) returns 5
' (the intDOW parameter overrides the day portion of the date)
Dim dtmFirst As Date
Dim intCount As Integer
Dim intMonth As Integer
If (intDOW < vbSunday Or intDOW > vbSaturday) Then
' Caller must not have specified DOW, or it
' was an invalid number.
intDOW = Weekday(dtmDate)
End If
intMonth = Month(dtmDate)
' Find the first day of the month
dtmFirst = DateSerial(Year(dtmDate), intMonth, 1)
' Move dtmFirst forward until it hits the
' matching day number.
Do While Weekday(dtmFirst) <> intDOW
dtmFirst = dtmFirst + 1
Loop
' Now, dtmFirst is sitting on the first day
' of the requested number in the month. Just count
' how many of that day type there are in the month.
intCount = 0
Do While Month(dtmFirst) = intMonth
intCount = intCount + 1
dtmFirst = dtmFirst + 7
Loop
dhCountDOWInMonth = intCount
End Function
Function dhAgeUnused(dtmBD As Date, Optional dtmDate As Date = 0) _
As Integer
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
Dim intAge As Integer
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
intAge = DateDiff("yyyy", dtmBD, dtmDate)
If dtmDate < DateSerial(Year(dtmDate), Month(dtmBD), Day(dtmBD)) Then
intAge = intAge - 1
End If
dhAgeUnused = intAge
End Function
Function dhAge(dtmBD As Date, Optional dtmDate As Date = 0) As Integer
' Calculate a person's age, given their birthdate and
' an optional "current" date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmBD:
' The birthdate (or any other anniversary date)
' dtmDate:
' The reference date. If omitted, the code uses today's
' date.
' Out:
' Return Value:
' The number of fulls years between dtmBD and dtmDate.
' Example:
' dhAge(#5/22/59#, #1/1/97#) returns 37, since the anniversary
' hasn't passed yet (dateDiff would return 38).
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhAge = DateDiff("yyyy", dtmBD, dtmDate) + _
(dtmDate < DateSerial(Year(dtmDate), Month(dtmBD), Day(dtmBD)))
End Function
Function dhFormatInterval(dtmStart As Date, datend As Date, _
Optional strFormat As String = "H:MM:SS") As String
' Return the difference between two times,
' formatted as specified in strFormat.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' GetTimeDelimiter
' In:
' dtmStart:
' starting date for the interval, including a time portion
' datend:
' ending date for the interval, including a time portion
' strFormat (optional):
' format specifier, as shown below. (Default: "H:MM:SS")
' Out:
' Return Value:
' The formatted time difference.
' Comment:
' Due to the way the calculations are performed, the largest interval
' is 68 years or so.
' Example:
' Using #1/1/97 12:00 PM# and #1/4/97 2:45:45 PM# as the dates, and one
' of the following format templates,
' dhFormatInterval(#1/1/97 12:00 PM#, #1/4/97 2:45:45 PM#, "<format>")
' will return (using each of the following format strings):
' D H 3 Days 3 Hours
' D H M 3 Days 2 Hours 46 Minutes
' D H M S 3 Days 2 Hours 45 Minutes 45 Seconds
' D H:MM 3 Days 2:46
' D HH:MM 3 Days 02:46
' D HH:MM:SS 3 Days 02:45:45
' H M 74 Hours 46 Minutes
' H:MM 74:46 (leading 0 on minutes, if necessary)
' H:MM:SS 74:45:45
' M S 4485 Minutes 45 Seconds
' M:SS 4485:45 (leading 0 on seconds, if necessary)
Dim lngSeconds As Long
Dim sngMinutes As Single
Dim sngHours As Single
Dim sngDays As Single
Dim intSeconds As Integer
Dim intMinutes As Integer
Dim intHours As Integer
Dim intRoundedHours As Integer
Dim intRoundedMinutes As Integer
Dim strDay As String
Dim strHour As String
Dim strMinute As String
Dim strSecond As String
Dim strOut As String
Dim lngFullDays As Long
Dim lngFullHours As Long
Dim lngFullMinutes As Long
Dim strDelim As String
' If you don't want to use the local delimiter,
' but a specific one, replace the next line with
' this:
' strDelim = ":"
strDelim = GetTimeDelimiter()
' Calculate the full number of seconds in the interval.
' This limits the calculation to 2 billion seconds (68 years
' or so), but that's not too bad. Then calculate the
' difference in minutes, hours, and days, as well.
lngSeconds = DateDiff("s", dtmStart, datend)
sngMinutes = lngSeconds / 60
sngHours = sngMinutes / 60
sngDays = sngHours / 24
' Get the full hours and minutes, for later display.
lngFullDays = Int(sngDays)
lngFullHours = Int(sngHours)
lngFullMinutes = Int(sngMinutes)
' Get the incremental amount of each unit.
intHours = Int((sngDays - lngFullDays) * 24)
intMinutes = Int((sngHours - lngFullHours) * 60)
intSeconds = CInt((sngMinutes - lngFullMinutes) * 60)
' In some instances, time values must be rounded.
' The next two lines depend on the fact that a true statement
' has a value of -1, and a false statement has a value of 0.
' The code needs to add 1 to the value if the following expression
' is true, and 0 if not.
intRoundedHours = intHours - (intMinutes > 30)
intRoundedMinutes = intMinutes - (intSeconds > 30)
strDay = "Days"
strHour = "Hours"
strMinute = "Minutes"
strSecond = "Seconds"
If lngFullDays = 1 Then strDay = "Day"
Select Case strFormat
Case "D H"
If intRoundedHours = 1 Then strHour = "Hour"
strOut = lngFullDays & " " & strDay & " " & _
intRoundedHours & " " & strHour
Case "D H M"
If intHours = 1 Then strHour = "Hour"
If intRoundedMinutes = 1 Then strMinute = "Minute"
strOut = lngFullDays & " " & strDay & " " & _
intHours & " " & strHour & " " & _
intRoundedMinutes & " " & strMinute
Case "D H M S"
If intHours = 1 Then strHour = "Hour"
If intMinutes = 1 Then strMinute = "Minute"
If intSeconds = 1 Then strSecond = "Second"
strOut = lngFullDays & " " & strDay & " " & _
intHours & " " & strHour & " " & _
intMinutes & " " & strMinute & " " & _
intSeconds & " " & strSecond
Case "D H:MM" ' 3 Days 2:46"
strOut = lngFullDays & " " & strDay & " " & _
intHours & strDelim & Format(intRoundedMinutes, "00")
Case "D HH:MM" ' 3 Days 02:46"
strOut = lngFullDays & " " & strDay & " " & _
Format(intHours, "00") & strDelim & _
Format(intRoundedMinutes, "00")
Case "D HH:MM:SS" ' 3 Days 02:45:45"
strOut = lngFullDays & " " & strDay & " " & _
Format(intHours, "00") & strDelim & _
Format(intMinutes, "00") & strDelim & _
Format(intSeconds, "00")
Case "H M" ' 74 Hours 46 Minutes"
If lngFullHours = 1 Then strHour = "Hour"
If intRoundedMinutes = 1 Then strMinute = "Minute"
strOut = lngFullHours & " " & strHour & " " & _
intRoundedMinutes & " " & strMinute
Case "H:MM" ' 74:46 (leading 0 on minutes, if necessary)
strOut = lngFullHours & strDelim & Format(intRoundedMinutes, "00")
Case "H:MM:SS" ' 74:45:45"
strOut = lngFullHours & strDelim & _
Format(intMinutes, "00") & strDelim & _
Format(intSeconds, "00")
Case "M S" ' 4485 Minutes 45 Seconds
If lngFullMinutes = 1 Then strMinute = "Minute"
If intSeconds = 1 Then strSecond = "Second"
strOut = lngFullMinutes & " " & strMinute & " " & _
intSeconds & " " & strSecond
Case "M:SS" ' 4485:45 (leading 0 on seconds, if necessary)"
strOut = lngFullMinutes & strDelim & _
Format(intSeconds, "00")
Case Else
strOut = ""
End Select
dhFormatInterval = strOut
End Function
Sub TestInterval()
Dim dtmStart As Date
Dim dtmEnd As Date
dtmStart = #1/1/1997 12:00:00 PM#
dtmEnd = #1/4/1997 2:45:45 PM#
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H M")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H M S")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D HH:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D HH:MM:SS")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H M")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H:MM:SS")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "M S")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "M:SS")
End Sub
Function dhCMinutes(dtmTime As Date) As Long
' Convert a date/time value to the number of
' minutes since midnight (that is, remove the date
' portion, and just work with the time part.) The
' return value can be used to calculate sums of
' elapsed time.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmTime:
' A date/time value
' Out:
' Return Value:
' Time portion of the input value, converted to minutes.
' Subtract off the whole portion of the date/time value
' and then convert from a fraction of a day to minutes.
dhCMinutes = TimeValue(dtmTime) * 24 * 60
End Function
Function dhCTimeStr(lngMinutes As Long) As String
' Convert from a number of minutes to a string
' that looks like a time value.
' This function is not aware of international settings.
'
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' GetTimeDelimiter
' In:
' lngMinutes:
' A quantity of minutes to be converted to an h:mm string
' Out:
' Return Value:
' The number of minutes, converted to h:mm format.
dhCTimeStr = Format(lngMinutes \ 60, "0") & _
GetTimeDelimiter() & Format(lngMinutes Mod 60, "00")
End Function
Private Function GetTimeDelimiter() As String
' Retrieve the time delimiter from, believe it or not,
' WIN.INI. This is the only reasonable solution
' to this problem, even in this day and age!
' Used by:
' dhCTimeStr
' dhFormatInterval
' Requires:
' GetProfileString declaration
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
Const conMaxSize = 10
Dim strBuffer As String
Dim intLen As Integer
strBuffer = Space(conMaxSize)
intLen = GetProfileString("intl", "sTime", "", strBuffer, conMaxSize)
GetTimeDelimiter = Left(strBuffer, intLen)
End Function
Function dhRoundTime(dtmTime As Date, intInterval As Integer) As Date
' Round the time value in varTime to the nearest minute
' interval in intInterval
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmTime:
' The original time
' intInterval:
' Interval to which to round dtmTime, in minutes.
' Must be a divisor of 60 (2, 3, 4, 5, 6, 10, 12, 15,
' 20, 30, or 60)
' Out:
' Return Value:
' The rounded time, to the nearest increment of intInterval.
' Example:
' dhRoundTime(#3/5/97 11:08 AM#, 15) returns
' #3/5/97 11:15:00 AM#
Dim sglTime As Single
Dim intHour As Integer
Dim intMinute As Integer
Dim lngdate As Long
' Get the date portion of the date/time value
lngdate = DateValue(dtmTime)
' Get the time portion as a number like 11.5 for 11:30.
sglTime = TimeValue(dtmTime) * 24
' Get the hour and store it away. Int truncates,
' CInt rounds, so use Int.
intHour = Int(sglTime)
' Get the number of minutes, and then round to the nearest
' occurrence of the interval specified.
intMinute = CInt((sglTime - intHour) * 60)
intMinute = CInt(intMinute / intInterval) * intInterval
' Build back up the original date/time value,
' rounded to the nearest interval.
dhRoundTime = CDate(lngdate + _
((intHour + intMinute / 60) / 24))
End Function- Thread starter
- #4
And the rest:
Code:
Select Case strFormat
Case "MMDDYY"
intYear = lngdate Mod 100
intMonth = lngdate \ 10000
intDay = (lngdate \ 100) Mod 100
Case "MMDDYYYY"
intYear = lngdate Mod 10000
intMonth = lngdate \ 1000000
intDay = (lngdate \ 10000) Mod 100
Case "DDMMYY"
intYear = lngdate Mod 100
intMonth = (lngdate \ 100) Mod 100
intDay = lngdate \ 10000
Case "DDMMYYYY"
intYear = lngdate Mod 10000
intMonth = (lngdate \ 10000) Mod 100
intDay = lngdate \ 1000000
Case "YYMMDD", "YYYYMMDD"
intYear = lngdate \ 10000
intMonth = (lngdate \ 100) Mod 100
intDay = lngdate Mod 100
Case Else
fOk = False
End Select
If fOk Then
dhCNumdate = DateSerial(intYear, intMonth, intDay)
Else
dhCNumdate = Null
End If
End Function
Function dhCStrdate(strDate As String, Optional strFormat As String = "") As Date
' Given a string containing a date value, and a format
' string describing the information in the date string,
' convert the string into a real date value.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' strDate:
' String expression containing a date to be converted.
' strFormat (Optional):
' String expression containing a format specifier for the
' string in strdate. If omitted, the function uses "", which
' will cause it to use the Cdate function to attempt to
' conversion, just as it will if any other unknown format
' string is passed in.
'
' Allowable formats:
' "MMDDYY", "MMDDYYYY"
' "DDMMYY", "DDMMYYYY"
' "YYMMDD", "YYYYMMDD"
' "DD/MM/YY", "DD/MM/YYYY" ("/" stands for any delimiter in the date string)
' "YY/MM/DD", "YYYY/MM/DD"
' Out:
' Return Value:
' The value in strDate, converted to a date, if possible.
' Example:
' dhCStrdate("59/04/22", "YY/MM/DD") returns the real date #4/22/59#
'
Dim strYear As String
Dim strMonth As String
Dim strDay As String
Dim fDone As Boolean
Select Case strFormat
Case "MMDDYY", "MMDDYYYY"
strYear = Mid(strDate, 5)
strMonth = Left(strDate, 2)
strDay = Mid(strDate, 3, 2)
Case "DDMMYY", "DDMMYYYY"
strYear = Mid(strDate, 5)
strMonth = Mid(strDate, 3, 2)
strDay = Left(strDate, 2)
Case "YYMMDD"
strYear = Left(strDate, 2)
strMonth = Mid(strDate, 3, 2)
strDay = Right(strDate, 2)
Case "YYYYMMDD"
strYear = Left(strDate, 4)
strMonth = Mid(strDate, 5, 2)
strDay = Right(strDate, 2)
Case "DD/MM/YY", "DD/MM/YYYY"
strYear = Mid(strDate, 7)
strMonth = Mid(strDate, 4, 2)
strDay = Left(strDate, 2)
Case "YY/MM/DD"
strYear = Left(strDate, 2)
strMonth = Mid(strDate, 4, 2)
strDay = Right(strDate, 2)
Case "YYYY/MM/DD"
strYear = Left(strDate, 4)
strMonth = Mid(strDate, 6, 2)
strDay = Right(strDate, 2)
Case Else
' If none of the other formats were matched, just count on Cdate
' to do the conversion. It may fail, but we can't help out here.
dhCStrdate = CDate(strDate)
fDone = True
End Select
If Not fDone Then
dhCStrdate = DateSerial(Val(strYear), Val(strMonth), Val(strDay))
End If
End Function
Function dhDaysInMonth(Optional dtmDate As Date = 0) As Integer
' Return the number of days in the specified month.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmDate:
' date within the month in which you need the number of days.
' Use the current date, if none was specified.
' Out:
' Return Value:
' Number of days in the specified month.
' Example:
' dhDaysInMonth(#2/1/96#) returns 29.
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhDaysInMonth = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 1) - _
DateSerial(Year(dtmDate), Month(dtmDate), 1)
End Function
Function dhCountDOWInMonth(ByVal dtmDate As Date, _
Optional intDOW As Integer = 0) As Integer
' Calculate the number of specified days in
' the specified month.
'
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
'
' In:
' dtmDate:
' date value specifying the month and year
' If intDOW is missing, this date also
' supplies the day of week to count.
' intDOW: (Optional)
' If supplied, contains the day of week
' (vbSunday (1) - vbSaturday (7)) to be
' counted within the specified month/year.
' If not supplied, the function uses the
' day of week of the required date parameter.
' Out:
' Return value:
' The number of days matching intDOW (or dtmDate)
' in the specified month/year.
'
' Example:
' dhCountDOWInMonth(#11/96#, 6) returns 5
' (there were 5 Fridays in November 1996)
' dhCountDOWInMonth(#11/3/96#) returns 4
' (11/3/96 was a Sunday, and there were 4 Sundays in the month)
' dhCountDOWInMonth(#11/3/96#, 6) returns 5
' (the intDOW parameter overrides the day portion of the date)
Dim dtmFirst As Date
Dim intCount As Integer
Dim intMonth As Integer
If (intDOW < vbSunday Or intDOW > vbSaturday) Then
' Caller must not have specified DOW, or it
' was an invalid number.
intDOW = Weekday(dtmDate)
End If
intMonth = Month(dtmDate)
' Find the first day of the month
dtmFirst = DateSerial(Year(dtmDate), intMonth, 1)
' Move dtmFirst forward until it hits the
' matching day number.
Do While Weekday(dtmFirst) <> intDOW
dtmFirst = dtmFirst + 1
Loop
' Now, dtmFirst is sitting on the first day
' of the requested number in the month. Just count
' how many of that day type there are in the month.
intCount = 0
Do While Month(dtmFirst) = intMonth
intCount = intCount + 1
dtmFirst = dtmFirst + 7
Loop
dhCountDOWInMonth = intCount
End Function
Function dhAgeUnused(dtmBD As Date, Optional dtmDate As Date = 0) _
As Integer
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
Dim intAge As Integer
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
intAge = DateDiff("yyyy", dtmBD, dtmDate)
If dtmDate < DateSerial(Year(dtmDate), Month(dtmBD), Day(dtmBD)) Then
intAge = intAge - 1
End If
dhAgeUnused = intAge
End Function
Function dhAge(dtmBD As Date, Optional dtmDate As Date = 0) As Integer
' Calculate a person's age, given their birthdate and
' an optional "current" date.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmBD:
' The birthdate (or any other anniversary date)
' dtmDate:
' The reference date. If omitted, the code uses today's
' date.
' Out:
' Return Value:
' The number of fulls years between dtmBD and dtmDate.
' Example:
' dhAge(#5/22/59#, #1/1/97#) returns 37, since the anniversary
' hasn't passed yet (dateDiff would return 38).
If dtmDate = 0 Then
' Did the caller pass in a date? If not, use
' the current date.
dtmDate = Date
End If
dhAge = DateDiff("yyyy", dtmBD, dtmDate) + _
(dtmDate < DateSerial(Year(dtmDate), Month(dtmBD), Day(dtmBD)))
End Function
Function dhFormatInterval(dtmStart As Date, datend As Date, _
Optional strFormat As String = "H:MM:SS") As String
' Return the difference between two times,
' formatted as specified in strFormat.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' GetTimeDelimiter
' In:
' dtmStart:
' starting date for the interval, including a time portion
' datend:
' ending date for the interval, including a time portion
' strFormat (optional):
' format specifier, as shown below. (Default: "H:MM:SS")
' Out:
' Return Value:
' The formatted time difference.
' Comment:
' Due to the way the calculations are performed, the largest interval
' is 68 years or so.
' Example:
' Using #1/1/97 12:00 PM# and #1/4/97 2:45:45 PM# as the dates, and one
' of the following format templates,
' dhFormatInterval(#1/1/97 12:00 PM#, #1/4/97 2:45:45 PM#, "<format>")
' will return (using each of the following format strings):
' D H 3 Days 3 Hours
' D H M 3 Days 2 Hours 46 Minutes
' D H M S 3 Days 2 Hours 45 Minutes 45 Seconds
' D H:MM 3 Days 2:46
' D HH:MM 3 Days 02:46
' D HH:MM:SS 3 Days 02:45:45
' H M 74 Hours 46 Minutes
' H:MM 74:46 (leading 0 on minutes, if necessary)
' H:MM:SS 74:45:45
' M S 4485 Minutes 45 Seconds
' M:SS 4485:45 (leading 0 on seconds, if necessary)
Dim lngSeconds As Long
Dim sngMinutes As Single
Dim sngHours As Single
Dim sngDays As Single
Dim intSeconds As Integer
Dim intMinutes As Integer
Dim intHours As Integer
Dim intRoundedHours As Integer
Dim intRoundedMinutes As Integer
Dim strDay As String
Dim strHour As String
Dim strMinute As String
Dim strSecond As String
Dim strOut As String
Dim lngFullDays As Long
Dim lngFullHours As Long
Dim lngFullMinutes As Long
Dim strDelim As String
' If you don't want to use the local delimiter,
' but a specific one, replace the next line with
' this:
' strDelim = ":"
strDelim = GetTimeDelimiter()
' Calculate the full number of seconds in the interval.
' This limits the calculation to 2 billion seconds (68 years
' or so), but that's not too bad. Then calculate the
' difference in minutes, hours, and days, as well.
lngSeconds = DateDiff("s", dtmStart, datend)
sngMinutes = lngSeconds / 60
sngHours = sngMinutes / 60
sngDays = sngHours / 24
' Get the full hours and minutes, for later display.
lngFullDays = Int(sngDays)
lngFullHours = Int(sngHours)
lngFullMinutes = Int(sngMinutes)
' Get the incremental amount of each unit.
intHours = Int((sngDays - lngFullDays) * 24)
intMinutes = Int((sngHours - lngFullHours) * 60)
intSeconds = CInt((sngMinutes - lngFullMinutes) * 60)
' In some instances, time values must be rounded.
' The next two lines depend on the fact that a true statement
' has a value of -1, and a false statement has a value of 0.
' The code needs to add 1 to the value if the following expression
' is true, and 0 if not.
intRoundedHours = intHours - (intMinutes > 30)
intRoundedMinutes = intMinutes - (intSeconds > 30)
strDay = "Days"
strHour = "Hours"
strMinute = "Minutes"
strSecond = "Seconds"
If lngFullDays = 1 Then strDay = "Day"
Select Case strFormat
Case "D H"
If intRoundedHours = 1 Then strHour = "Hour"
strOut = lngFullDays & " " & strDay & " " & _
intRoundedHours & " " & strHour
Case "D H M"
If intHours = 1 Then strHour = "Hour"
If intRoundedMinutes = 1 Then strMinute = "Minute"
strOut = lngFullDays & " " & strDay & " " & _
intHours & " " & strHour & " " & _
intRoundedMinutes & " " & strMinute
Case "D H M S"
If intHours = 1 Then strHour = "Hour"
If intMinutes = 1 Then strMinute = "Minute"
If intSeconds = 1 Then strSecond = "Second"
strOut = lngFullDays & " " & strDay & " " & _
intHours & " " & strHour & " " & _
intMinutes & " " & strMinute & " " & _
intSeconds & " " & strSecond
Case "D H:MM" ' 3 Days 2:46"
strOut = lngFullDays & " " & strDay & " " & _
intHours & strDelim & Format(intRoundedMinutes, "00")
Case "D HH:MM" ' 3 Days 02:46"
strOut = lngFullDays & " " & strDay & " " & _
Format(intHours, "00") & strDelim & _
Format(intRoundedMinutes, "00")
Case "D HH:MM:SS" ' 3 Days 02:45:45"
strOut = lngFullDays & " " & strDay & " " & _
Format(intHours, "00") & strDelim & _
Format(intMinutes, "00") & strDelim & _
Format(intSeconds, "00")
Case "H M" ' 74 Hours 46 Minutes"
If lngFullHours = 1 Then strHour = "Hour"
If intRoundedMinutes = 1 Then strMinute = "Minute"
strOut = lngFullHours & " " & strHour & " " & _
intRoundedMinutes & " " & strMinute
Case "H:MM" ' 74:46 (leading 0 on minutes, if necessary)
strOut = lngFullHours & strDelim & Format(intRoundedMinutes, "00")
Case "H:MM:SS" ' 74:45:45"
strOut = lngFullHours & strDelim & _
Format(intMinutes, "00") & strDelim & _
Format(intSeconds, "00")
Case "M S" ' 4485 Minutes 45 Seconds
If lngFullMinutes = 1 Then strMinute = "Minute"
If intSeconds = 1 Then strSecond = "Second"
strOut = lngFullMinutes & " " & strMinute & " " & _
intSeconds & " " & strSecond
Case "M:SS" ' 4485:45 (leading 0 on seconds, if necessary)"
strOut = lngFullMinutes & strDelim & _
Format(intSeconds, "00")
Case Else
strOut = ""
End Select
dhFormatInterval = strOut
End Function
Sub TestInterval()
Dim dtmStart As Date
Dim dtmEnd As Date
dtmStart = #1/1/1997 12:00:00 PM#
dtmEnd = #1/4/1997 2:45:45 PM#
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H M")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H M S")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D H:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D HH:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "D HH:MM:SS")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H M")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H:MM")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "H:MM:SS")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "M S")
Debug.Print dhFormatInterval(dtmStart, dtmEnd, "M:SS")
End Sub
Function dhCMinutes(dtmTime As Date) As Long
' Convert a date/time value to the number of
' minutes since midnight (that is, remove the date
' portion, and just work with the time part.) The
' return value can be used to calculate sums of
' elapsed time.
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmTime:
' A date/time value
' Out:
' Return Value:
' Time portion of the input value, converted to minutes.
' Subtract off the whole portion of the date/time value
' and then convert from a fraction of a day to minutes.
dhCMinutes = TimeValue(dtmTime) * 24 * 60
End Function
Function dhCTimeStr(lngMinutes As Long) As String
' Convert from a number of minutes to a string
' that looks like a time value.
' This function is not aware of international settings.
'
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' Requires:
' GetTimeDelimiter
' In:
' lngMinutes:
' A quantity of minutes to be converted to an h:mm string
' Out:
' Return Value:
' The number of minutes, converted to h:mm format.
dhCTimeStr = Format(lngMinutes \ 60, "0") & _
GetTimeDelimiter() & Format(lngMinutes Mod 60, "00")
End Function
Private Function GetTimeDelimiter() As String
' Retrieve the time delimiter from, believe it or not,
' WIN.INI. This is the only reasonable solution
' to this problem, even in this day and age!
' Used by:
' dhCTimeStr
' dhFormatInterval
' Requires:
' GetProfileString declaration
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
Const conMaxSize = 10
Dim strBuffer As String
Dim intLen As Integer
strBuffer = Space(conMaxSize)
intLen = GetProfileString("intl", "sTime", "", strBuffer, conMaxSize)
GetTimeDelimiter = Left(strBuffer, intLen)
End Function
Function dhRoundTime(dtmTime As Date, intInterval As Integer) As Date
' Round the time value in varTime to the nearest minute
' interval in intInterval
' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.
' In:
' dtmTime:
' The original time
' intInterval:
' Interval to which to round dtmTime, in minutes.
' Must be a divisor of 60 (2, 3, 4, 5, 6, 10, 12, 15,
' 20, 30, or 60)
' Out:
' Return Value:
' The rounded time, to the nearest increment of intInterval.
' Example:
' dhRoundTime(#3/5/97 11:08 AM#, 15) returns
' #3/5/97 11:15:00 AM#
Dim sglTime As Single
Dim intHour As Integer
Dim intMinute As Integer
Dim lngdate As Long
' Get the date portion of the date/time value
lngdate = DateValue(dtmTime)
' Get the time portion as a number like 11.5 for 11:30.
sglTime = TimeValue(dtmTime) * 24
' Get the hour and store it away. Int truncates,
' CInt rounds, so use Int.
intHour = Int(sglTime)
' Get the number of minutes, and then round to the nearest
' occurrence of the interval specified.
intMinute = CInt((sglTime - intHour) * 60)
intMinute = CInt(intMinute / intInterval) * intInterval
' Build back up the original date/time value,
' rounded to the nearest interval.
dhRoundTime = CDate(lngdate + _
((intHour + intMinute / 60) / 24))
End Function- Status
Similar threads
- Locked
- Question
- Locked
- Question
- Locked
- Question