Ni VBA, ni Access ne fournit quelque support pour travailler avec les jours
ouvrables (généralement, du lundi au vendredi).
Le bouquin VBA Developers Handbook (Sybex) contient plusieurs
fonctions qui retournent le prochain jour ouvrable, ou qui trouvent le dernier
jour d'un mois, par exemple. Pour régler le cas des jours fériés, la
fonction SkipHolidays accepte un recordset comme argument,
recordset qui contient toutes les dates considérées comme fériées.
Pour accroître la facilité d'utilisation, cette fonction fut réécrite
pour accepter un vecteur, un peu comme la fonction WorkDay
d'Excel.
Voir la fin du code fourni pour personnaliser les journées non ouvrables répétitives, les jours de "la fin de semaine" si vous préférez.
Public Function dhAddWorkDaysA(lngDays As Long, _
Optional dtmDate As Date = 0, _
Optional adtmDates As Variant) As Date
Dim lngCount As Long
Dim dtmTemp As Date
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
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
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
Dim dtmTemp As 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
Dim dtmTemp As 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
Dim intDays As Integer
Dim dtmTemp As Date
Dim intSubtract As Integer
>
If dtmEnd < dtmStart Then
dtmTemp = dtmStart
dtmStart = dtmEnd
dtmEnd = dtmTemp
End If
dtmStart = SkipHolidaysA(adtmDates, dtmStart, 1)
dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1)
If dtmStart > dtmEnd Then
dhCountWorkdaysA = 0
Else
intDays = dtmEnd - dtmStart + 1
intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2)
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
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
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
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:
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:
Resume ExitHere
End Function
Private Function IsWeekend(dtmTemp As Variant) As Boolean
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
Dim strCriteria As String
Dim strFieldName As String
Dim lngItem As Long
Dim blnFound As Boolean
On Error GoTo HandleErrors
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:
Resume ExitHere
End Function
' ********* Code End **************
