Untitled

Using SQL to calculate a date within a certain date range
Option Compare Database
Option Explicit

' ********* Code Start **************
'
' Modified from code in
' "Visual Basic Language Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 2000; Sybex, Inc. All rights reserved.
'

Public Function dhAddWorkDaysA(lngDays As Long, Optional dtmDate As Date = 0)
'Optional adtmDates As Variant) As Date
    ' Add the specified number of work days to the
    ' specified date.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' In:
    '   lngDays:
    '       Number of work days to add to the start date.
    '   dtmDate:
    '       date on which to start looking.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value, if that's what you want.
    ' Out:
    '   Return Value:
    '       The date of the working day lngDays from the start, taking
    '       into account weekends and holidays.
    ' Example:
    '   dhAddWorkDaysA(10, #2/9/2000#, Array(#2/16/2000#, #2/17/2000#))
    '   returns #2/25/2000#, which is the date 10 work days
    '   after 2/9/2000, if you treat 2/16 and 2/17 as holidays
    '   (just made-up holidays, for example purposes only).

    ' Did the caller pass in a date? If not, use
    ' the current date.
    Dim lngCount As Long
    Dim dtmTemp As Date
    Dim adtmDates() As Variant

    'loadup the adtmDates with all the records from the table tblNon_working_days

    Dim rst As DAO.Recordset
    Dim i As Long

    Set rst = DBEngine(0)(0).OpenRecordset("SELECT Date FROM tblNon_working_days", dbOpenForwardOnly)
    With rst
        If .RecordCount > 0 Then
            i = 1
            Do Until .EOF
                ReDim Preserve adtmDates(i)
                adtmDates(i) = !Date
                .MoveNext
               i = i + 1
            Loop
        End If
    End With

    rst.Close

    Set rst = Nothing

    If dtmDate = 0 Then
        dtmDate = Date
    End If

    dtmTemp = dtmDate
    For lngCount = 1 To lngDays
        dtmTemp = dhNextWorkdayA(dtmTemp, adtmDates)
    Next lngCount
    dhAddWorkDaysA = dtmTemp
End Function

Public Function dhNextWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date

    ' Return the next working day after the specified date.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Requires:
    '   SkipHolidays
    '   IsWeekend

    ' In:
    '   dtmDate:
    '       date on which to start looking.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' 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
    '   dtmDate = dhNextWorkdayA(#5/23/1997#, #5/26/97#)
    '   ' dtmDate should be 5/27/97, because 5/26/97 is Memorial day.

    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If

    dhNextWorkdayA = SkipHolidaysA(adtmDates, dtmDate + 1, 1)
End Function

Public Function dhPreviousWorkdayA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date

    ' Return the previous working day before the specified date.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Requires:
    '   SkipHolidays
    '   IsWeekend

    ' In:
    '   dtmDate:
    '       date on which to start looking.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the previous working day, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the next working date before 1/1/2000

    '   dtmDate = dhPreviousWorkdayA(#1/1/2000#, Array(#12/31/1999#, #1/1/2000#))
    '   ' dtmDate should be 12/30/1999, because of the New Year's holidays.

    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If

    dhPreviousWorkdayA = SkipHolidaysA(adtmDates, dtmDate - 1, -1)
End Function

Public Function dhFirstWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date

    ' Return the first working day in the month specified.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Requires:
    '   SkipHolidays
    '   IsWeekend

    ' In:
    '   dtmDate:
    '       date within the month of interest.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the first working day in the month, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the first working day in 1999
    '   dtmDate = dhFirstWorkdayInMonthA(#1/1/1999#, #1/1/1999#)

    Dim dtmTemp As Date

    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If

    dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate), 1)
    dhFirstWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, 1)
End Function

Public Function dhLastWorkdayInMonthA( _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant = Empty) As Date

    ' Return the last working day in the month specified.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Requires:
    '   SkipHolidays
    '   IsWeekend

    ' In:
    '   dtmDate:
    '       date within the month of interest.
    '       Use the current date, if none was specified.
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       The date of the last working day in the month, taking
    '       into account weekends and holidays.
    ' Example:
    '   ' Find the last working day in 1999
    '   dtmDate = dhLastWorkdayInMonthA(#12/1/1999#, #12/31/1999#)

    Dim dtmTemp As Date

    ' Did the caller pass in a date? If not, use
    ' the current date.
    If dtmDate = 0 Then
        dtmDate = Date
    End If

    dtmTemp = DateSerial(Year(dtmDate), Month(dtmDate) + 1, 0)
    dhLastWorkdayInMonthA = SkipHolidaysA(adtmDates, dtmTemp, -1)
End Function

Public Function dhCountWorkdaysA(ByVal dtmStart As Date, ByVal dtmEnd As Date, _
 Optional adtmDates As Variant = Empty) _
 As Integer

    ' Count the business days (not counting weekends/holidays) in
    ' a given date range.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Requires:
    '   SkipHolidays
    '   CountHolidays
    '   IsWeekend

    ' In:
    '   dtmStart:
    '       Date specifying the start of the range (inclusive)
    '   dtmEnd:
    '       Date specifying the end of the range (inclusive)
    '       (dates will be swapped if out of order)
    '   adtmDates (Optional):
    '       Array containing holiday dates. Can also be a single
    '       date value.
    ' Out:
    '   Return Value:
    '       Number of working days (not counting weekends and optionally, holidays)
    '       in the specified range.
    ' Example:
    '   Debug.Print dhCountWorkdaysA(#7/2/2000#, #7/5/2000#, _
    '    Array(#1/1/2000#, #7/4/2000#))
    '
    '   returns 2, because 7/2/2000 is Sunday, 7/4/2000 is a holiday,
    '   leaving 7/3 and 7/5 as workdays.

    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 = SkipHolidaysA(adtmDates, dtmStart, 1)
    dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1)
    If dtmStart > dtmEnd Then
        ' Sorry, no Workdays to be had. Just return 0.
        dhCountWorkdaysA = 0
    Else
        intDays = dtmEnd - dtmStart + 1

        ' Subtract off weekend days.  Do this by figuring out how
        ' many calendar weeks there are between the dates, and
        ' multiplying the difference by two (because 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.
        intSubtract = intSubtract + _
         CountHolidaysA(adtmDates, dtmStart, dtmEnd)

        dhCountWorkdaysA = intDays - intSubtract
    End If
End Function

Private Function CountHolidaysA( _
adtmDates As Variant, _
dtmStart As Date, dtmEnd As Date) As Long

    ' Count holidays between two end dates.
    '
    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Required by:
    '   dhCountWorkdays

    ' Requires:
    '   IsWeekend


    Dim lngItem As Long
    Dim lngCount As Long
    Dim blnFound As Long
    Dim dtmTemp As Date

    On Error GoTo HandleErr
    lngCount = 0
    Select Case VarType(adtmDates)
        Case vbArray + vbDate, vbArray + vbVariant
            ' You got an array of variants, or of dates.
            ' Loop through, looking for non-weekend values
            ' between the two endpoints.
            For lngItem = LBound(adtmDates) To UBound(adtmDates)
                dtmTemp = adtmDates(lngItem)
                If dtmTemp >= dtmStart And dtmTemp <= dtmEnd Then
                    If Not IsWeekend(dtmTemp) Then
                        lngCount = lngCount + 1
                    End If
                End If
            Next lngItem
        Case vbDate
            ' You got one date. So see if it's a non-weekend
            ' date between the two endpoints.
            If adtmDates >= dtmStart And adtmDates <= dtmEnd Then
                If Not IsWeekend(adtmDates) Then
                    lngCount = 1
                End If
            End If
    End Select

ExitHere:
    CountHolidaysA = lngCount
    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 FindItemInArray(varItemToFind As Variant, _
avarItemsToSearch As Variant) As Boolean
    Dim lngItem As Long

    On Error GoTo HandleErrors

    For lngItem = LBound(avarItemsToSearch) To UBound(avarItemsToSearch)
        If avarItemsToSearch(lngItem) = varItemToFind Then
            FindItemInArray = True
            GoTo ExitHere
        End If
    Next lngItem

ExitHere:
    Exit Function

HandleErrors:
    ' Do nothing at all.
    ' Return False.
    Resume ExitHere
End Function

Private Function IsWeekend(dtmTemp As Variant) 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.

    ' Modified from code in "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Required by:
    '   SkipHolidays
    '   dhFirstWorkdayInMonth
    '   dbLastWorkdayInMonth
    '   dhNextWorkday
    '   dhPreviousWorkday
    '   dhCountWorkdays

    If VarType(dtmTemp) = vbDate Then
        Select Case WeekDay(dtmTemp)
            Case vbSaturday, vbSunday
                IsWeekend = True
            Case Else
                IsWeekend = False
        End Select
    End If
End Function

Private Function SkipHolidaysA( _
adtmDates As Variant, _
dtmTemp As Date, intIncrement As Integer) As Date
    ' Skip weekend days, and holidays in the array referred to by adtmDates.
    ' Return dtmTemp + as many days as it takes to get to a day that's not
    ' a holiday or weekend.

    ' Modified from code in
    ' "Visual Basic Language Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 2000; Sybex, Inc. All rights reserved.

    ' Required by:
    '   dhFirstWorkdayInMonthA
    '   dbLastWorkdayInMonthA
    '   dhNextWorkdayA
    '   dhPreviousWorkdayA
    '   dhCountWorkdaysA

    ' Requires:
    '   IsWeekend

    Dim strCriteria As String
    Dim strFieldName As String
    Dim lngItem As Long
    Dim blnFound As Boolean

    On Error GoTo HandleErrors

    ' 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 adtmDates an item for every day in the year (!)
    ' this should finally converge on a weekday.

    Do
        Do While IsWeekend(dtmTemp)
            dtmTemp = dtmTemp + intIncrement
        Loop
        Select Case VarType(adtmDates)
            Case vbArray + vbDate, vbArray + vbVariant
                Do
                    blnFound = FindItemInArray(dtmTemp, adtmDates)
                    If blnFound Then
                        dtmTemp = dtmTemp + intIncrement
                    End If
                Loop Until Not blnFound
            Case vbDate
                If dtmTemp = adtmDates Then
                    dtmTemp = dtmTemp + intIncrement
                End If
        End Select
    Loop Until Not IsWeekend(dtmTemp)

ExitHere:
    SkipHolidaysA = dtmTemp
    Exit Function

HandleErrors:
    ' 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 array.
    Resume ExitHere

End Function