Option Compare Database
Option Explicit
Public Function funNetWorkDays(ByRef dteStartDate As Date, _
ByRef dteEndDate As Date, _
blnCountFirstDay As Boolean, _
Optional ByRef strHolidays As String = "tblHolidays") As Integer
' ************************************************************
' Created by : Microsoft
' Parameters : Start Date, End Date
' Returns : Integer
' Remarks : This routine returns the number of working days between two selected dates.
' Returns -1 in case of error.
' This routine requires a 'Holidays' table be maintained with the following fields:
' *ID - Autonumber
' *Description - String
' *Holiday - Date(Short)
' Changes :
' ************************************************************
On Error GoTo funNetWorkDays_Err
Dim strProcName As String
Dim nWeekdays As Integer
Dim nHolidays As Integer
Dim strWhere As String
strProcName = "funNetWorkDays"
' DateValue returns the date part only.
dteStartDate = DateValue(dteStartDate)
dteEndDate = DateValue(dteEndDate)
nWeekdays = funWeekdays(dteStartDate, dteEndDate)
If nWeekdays = -1 Then
funNetWorkDays = -1
GoTo funNetWorkDays_Exit
End If
'If blnCountFirstDay is FALSE, then decrement nWeekdays by 1 - we want total days elapsed, not number of days involved.
If Not blnCountFirstDay Then nWeekdays = nWeekdays - 1
strWhere = "[Holiday] >= #" & dteStartDate _
& "# AND [Holiday] <= #" & dteEndDate & "#"
' Count the number of holidays.
nHolidays = DCount(Expr:="[Holiday]", _
Domain:=strHolidays, _
Criteria:=strWhere)
funNetWorkDays = nWeekdays - nHolidays
funNetWorkDays_Exit:
Exit Function
funNetWorkDays_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume funNetWorkDays_Exit
End Function
Public Function funWeekdays(ByRef dteStartDate As Date, _
ByRef dteEndDate As Date) As Integer
' ************************************************************
' Created by : Microsoft
' Parameters : Start Date, End Date
' Returns : Integer
' Remarks : This routine returns the number of working days between two selected dates.
' Returns -1 in case of error.
' Changes : Added switch to see if first day should be counted.
' ************************************************************
On Error GoTo funWeekdays_Err
Dim strProcName As String
' The number of weekend days per week.
Const ncNumberOfWeekendDays As Integer = 2
' The number of days inclusive.
Dim varDays As Variant
' The number of weekend days.
Dim varWeekendDays As Variant
' Temporary storage for datetime.
Dim dtmX As Date
strProcName = "funWeekdays"
' If the end date is earlier, swap the dates.
If dteEndDate < dteStartDate Then
dtmX = dteStartDate
dteStartDate = dteEndDate
dteEndDate = dtmX
End If
' Calculate the number of days inclusive (+ 1 is to add back startDate).
varDays = DateDiff(Interval:="d", _
date1:=dteStartDate, _
date2:=dteEndDate) + 1
' Calculate the number of weekend days.
varWeekendDays = (DateDiff(Interval:="ww", _
date1:=dteStartDate, _
date2:=dteEndDate) _
* ncNumberOfWeekendDays) _
+ IIf(DatePart(Interval:="w", _
Date:=dteStartDate) = vbSunday, 1, 0) _
+ IIf(DatePart(Interval:="w", _
Date:=dteEndDate) = vbSaturday, 1, 0)
' Calculate the number of weekdays.
funWeekdays = (varDays - varWeekendDays)
funWeekdays_Exit:
Exit Function
funWeekdays_Err:
MsgBox "Error occurred" & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, vbCritical, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume funWeekdays_Exit
End Function
