Code:
Option Compare Database
Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : NetWorkMinutes
' Author : Rod
' Date : 13/12/2012
' Purpose : Returns the number of work minutes between two date-time argumnets.
'
' A date-time is held in Access as a double precision number, the integer
' part is a relative day number and the decimal part is the time of day.
' To strip out a 'pure' date I use the Int (integer) function. To separate
' the time of date I use date-time - Int(date-time). I have used DateAdd in
' this procedure for clarity; I could have simply added an integer to a
' date-time value to add days.
'
' Much of the procedure is given over to checking and adjusting the supplied
' dates. After each adjustment it is important to check that the end date-time
' is still later than the start date-time.
'
' I update the arguments in place. As they are passed by reference, the calling
' procedure may interrogate them once control is passed back to see what the
' actual adjusted values are.
'---------------------------------------------------------------------------------------
Public Function NetWorkMinutes(rdteStart As Date, rdteEnd As Date) As Long
Dim lngFirstDayMins As Long
Dim lngLastDayMins As Long
Dim dteWork As Date
Dim dteEnd As Date
Dim intFullWorkDays As Integer
Dim dblStartTime As Double
Dim dblEndTime As Double
'Supplied end date-time earlier or equal start date-time, so exit.
If rdteEnd <= rdteStart Then NetWorkMinutes = 0: GoTo Exit_Procedure
'Check that time of day is sensible and adjust if necessary.
dblStartTime = TimeValue("06:30:00")
dblEndTime = TimeValue("22:00:00")
Select Case rdteStart - Int(rdteStart)
Case Is < dblStartTime 'Earlier than 06:30 am.
rdteStart = Int(rdteStart) + dblStartTime
Case Is >= dblEndTime 'Later than 22:00 pm.
rdteStart = DateAdd("d", 1, Int(rdteStart)) + dblStartTime
End Select
Select Case rdteEnd - Int(rdteEnd)
Case Is <= dblStartTime 'Equal or earlier than 8 am.
rdteEnd = DateAdd("d", -1, Int(rdteEnd)) + dblEndTime
Case Is > dblEndTime 'Later than 5 pm.
rdteEnd = Int(rdteEnd) + dblEndTime
End Select
'Adjusted end date-time earlier or equal start date-time, so exit.
If rdteEnd <= rdteStart Then NetWorkMinutes = 0: GoTo Exit_Procedure
'If the start date is a Saturday or Sunday then reset it to 8 am the
'following Monday. If it's a holiday reset to following day.
Do
Select Case DatePart("w", rdteStart, vbMonday)
Case 6 'Saturday
rdteStart = DateAdd("d", 2, Int(rdteStart)) + dblStartTime
Case 7 'Sunday
rdteStart = DateAdd("d", 1, Int(rdteStart)) + dblStartTime
Case Else
If IsHoliday(rdteStart) Then
rdteStart = DateAdd("d", 1, Int(rdteStart)) + dblStartTime
Else
Exit Do 'Not weekend or holiday.
End If
End Select
Loop
'If the end date is a Saturday or Sunday then reset it to 5 pm the
'previous Friday. If it's a holiday reset it to the previous day.
Do
Select Case DatePart("w", rdteEnd, vbMonday)
Case 6 'Saturday
rdteEnd = DateAdd("d", -1, Int(rdteEnd)) + dblEndTime
Case 7 'Sunday
rdteEnd = DateAdd("d", -2, Int(rdteEnd)) + dblEndTime
Case Else
If IsHoliday(rdteEnd) Then
rdteEnd = DateAdd("d", -1, Int(rdteEnd)) + dblEndTime
Else
Exit Do 'Not weekend or holiday.
End If
End Select
Loop
'Adjusted end date-time earlier or equal start date-time, so exit.
If rdteEnd <= rdteStart Then NetWorkMinutes = 0: GoTo Exit_Procedure
'Special case if adjusted date start equals adjusted date end.
'Else calculate first and last day minutes.
If Int(rdteStart) = Int(rdteEnd) Then
NetWorkMinutes = DateDiff("n", rdteStart, rdteEnd)
GoTo Exit_Procedure
Else
lngFirstDayMins = DateDiff("n", rdteStart - Int(rdteStart), dblEndTime)
lngLastDayMins = DateDiff("n", dblStartTime, rdteEnd - Int(rdteEnd))
End If
'Set the start and end dates for full work days (i.e. exclude first
'and last days) and iterate through period testing for holidays and weekends.
dteWork = Int(DateAdd("d", 1, rdteStart))
dteEnd = Int(DateAdd("d", -1, rdteEnd))
intFullWorkDays = 0
Do Until dteWork > dteEnd
If Not IsHoliday(dteWork) Then
Select Case DatePart("w", dteWork, vbMonday)
Case 6, 7
Case Else
intFullWorkDays = intFullWorkDays + 1
End Select
End If
dteWork = DateAdd("d", 1, dteWork)
Loop
NetWorkMinutes = CLng(intFullWorkDays * 540) + (lngFirstDayMins + lngLastDayMins)
Exit_Procedure:
Exit Function
End Function
Windows Vista 
Access 2010 64bit
Reply With Quote
