Source code for Issue Number 105

Copyright 1997-2000 by C&D Programming Corp. All Rights Reserved. Source code may not be reproduced except for use in a compiled executable. All rights reserved. If you would like to reprint any or all of this code please email us at info@codeoftheweek.com

Code of the Week Home


Source Code

Create a new module and paste this source code into it (or add it to the source code from issue 104). You should name this class module cBusinessDates. If you have any questions, email us at help@codeoftheweek.com

'----------------------------------------------------------------------
'
'   Module Name:    cBusinessDates
'   Written By:     C&D Programming Corp.
'   Create Date:    8/99
'   Copyright:      Copyright 1999 by C&D Programming Corp.  Source
'                   code may not be reproduced except for use in a
'                   compiled executable.  All rights reserved.  If
'                   you would like to reprint any or all of this
'                   code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Option Explicit

Public IncludeSaturdays As Boolean
Public IncludeSundays As Boolean

Private mbIncludeFirstDate As Boolean

Private Holidays As New Collection

Public Function HolidayExists(dDate As Date) As Boolean
   Dim dHoliday As Variant

   On Error Resume Next
   dHoliday = Holidays.Item("D" & dDate)
   HolidayExists = (Err = 0)
   ' clear any error if it exists
   Err.Clear
End Function

Public Sub HolidayAdd(dHoliday As Date)
   On Error Resume Next
   Holidays.Add dHoliday, "D" & dHoliday
   ' ignore errors since it usually means it was already added to the collection
   If Err Then
      Err.Clear
   End If
End Sub

Public Sub HolidayRemove(dHoliday As Date)
   On Error Resume Next
   Holidays.Remove "D" & dHoliday
   ' ignore errors since it usually means it was just not in the collection
   If Err Then
      Err.Clear
   End If
End Sub

Public Sub HolidayClear()
   Dim x As Long
   For x = 1 To Holidays.Count
      Holidays.Remove 1
   Next
End Sub

Public Property Let IncludeFirstDate(bInc As Boolean)
   mbIncludeFirstDate = bInc
End Property

Public Property Get IncludeFirstDate() As Boolean
   IncludeFirstDate = mbIncludeFirstDate
End Property

'
'  This function does not count the dDate2.  If dDate2 is a Sunday and you chose to count
'  Sundays it will not include dDate2.  It returns the number of days between those two days.
'
Public Function BusinessDayCount(ByVal dDate As Date, ByVal iDays As Integer) As Date
   Dim dFirstDate As Date
   Dim dCurDate As Date
   Dim iDayCount As Integer
   Dim eDay As VbDayOfWeek
   Dim dHoliday As Variant

   ' adjust for which date will be included in the count (the first or the last)
   If IncludeFirstDate Then
      dFirstDate = dDate
   Else
      dFirstDate = dDate + 1
   End If

   ' loop through all dates and update the day count appropriately.
   dCurDate = dFirstDate
   iDayCount = 0
   Do Until iDayCount = iDays
      eDay = WeekDay(dCurDate)
      If IncludeSaturdays And eDay = vbSaturday Then
         iDayCount = iDayCount + 1
      End If
      If IncludeSundays And eDay = vbSunday Then
         iDayCount = iDayCount + 1
      End If
      If eDay >= vbMonday And eDay <= vbFriday Then
         If Not HolidayExists(dCurDate) Then
            iDayCount = iDayCount + 1
         End If
      End If
      If iDayCount <> iDays Then
         dCurDate = dCurDate + 1
      End If
   Loop

   BusinessDayCount = dCurDate
End Function

Private Sub Class_Initialize()
   IncludeFirstDate = True
   IncludeSundays = False
   IncludeSaturdays = False
End Sub