Calculate date ranges excluding weekends and company holidays

After trying a few of the scripts on this site and discovering that none of them actually worked the way I wanted them to, I decided to write my own that actually went beyond the scope of one week. To use this script, you need a form with fields StartDate (Date/Time-Editable), Length (Number-Editable), EndDate (Date/Time-Computed when composed, default "") and Range (Text-Computed when composed, default ""). In addition you need a form named "Holiday | HOL" to create the holidays with a field named StartDate (Date/Time-Editable) for the date of the holiday. Create a document for each of the holidays. You also need a script library titled "Calculations" to hold the code.

'In the Globals\Options section of the form Option Public Option Declare Use "Calculations" 'In the QuerySave Event of form: Set s = New NotesSession Set db = s.CurrentDatabase Set doc = source.document If CalcEndDate(doc.StartDate(0),doc.Length(0)) Then Call doc.Save(False,False) Else Continue = False End If 'In the "Calculations" Script Library: 'Options: Option Public Option Declare %INCLUDE "lserr.lss" %INCLUDE "lsxbeerr.lss" %INCLUDE "lsxuierr.lss" 'Declarations: Dim s As NotesSession Dim db As NotesDatabase Dim dc As NotesdocumentCollection Function CalcEndDate(varStartDate_p As Variant, intLength_p As Integer) On Error Goto CalcEndDateErr CalcEndDate = True Dim ndtmEndDate As NotesDateTime Dim ndtmEndSaveDate As NotesDateTime Dim ndtmStartDate As NotesDateTime Dim ndrRange As NotesDateRange Dim intHolidays As Integer Dim intWeekend As Integer Dim intCounter As Integer Dim intStopFlag As Integer Dim intNewLength As Integer Dim intSaveLength As Integer Set ndtmEndDate = New NotesDateTime(varStartDate_p) Set ndrRange = s.CreateDateRange Call ndtmEndDate.AdjustDay(intLength_p - 1, True) intNewLength = intLength_p intSaveLength = intLength_p intStopFlag = 0 Do Until intStopFlag = 1 intHolidays = 0 intWeekend = 0 intSaveLength = intNewLength Set ndtmEndSaveDate = New NotesDateTime(varStartDate_p) Set ndtmStartDate = New NotesDateTime(varStartDate_p) Call ndtmEndSaveDate.AdjustDay(intNewLength) intHolidays = CheckHolidays(ndtmStartDate, ndtmEndSaveDate) intNewLength = intLength_p + intHolidays intWeekend = CheckWeekends(ndtmStartDate, intNewLength) intNewLength = intLength_p + intWeekend + intHolidays If intSaveLength = intNewLength Then Call ndtmEndDate.AdjustDay(intNewLength-intLength_p,True) intStopFlag = 1 End If Loop Set ndtmStartDate = New NotesDateTime(varStartDate_p) Set ndrRange.StartDateTime = ndtmStartDate Set ndrRange.EndDateTime = ndtmEndDate doc.Range = ndrRange.Text doc.EndDate = ndtmEndDate.DateOnly CalcEndDateExit: Exit Function CalcEndDateErr: CalcEndDate = False Messagebox "Error Number " & Err & " occured at line number " & Erl & " due to: " & Error(Err) Resume CalCEndDateExit End Function Function CheckHolidays(varStartDate_p As Variant, varEndDate_p As Variant) As Integer CheckHolidays = 0 Dim strSearch As String Dim holdoc As NotesDocument Dim intcount As Integer Dim varHolidays() As Variant Dim ndtmValue As NotesDateTime Dim strDate As String Dim ndtmCheck As New NotesDateTime(varStartDate_p.DateOnly) Dim ndtmEnd As New NotesDateTime(varEndDate_p.DateOnly) Dim ndtmNewEnd As New NotesDateTime(varEndDate_p.DateOnly) strSearch = {((Form="Holiday")|(Form="HOL"))} Set dc = db.Search(strSearch,Nothing,0) Redim varHolidays(dc.Count-1) For intcount = 1 To dc.Count Set holdoc = dc.GetNthDocument(intCount) varHolidays(intCount-1) = holdoc.StartDate(0) Next For intCount = 0 To Ubound(varHolidays) Set ndtmCheck = New NotesDateTime(varStartDate_p.DateOnly) strDate = varHolidays(intCount) Set ndtmValue = New NotesDateTime(strDate) Do Until ndtmCheck.DateOnly = ndtmNewEnd.DateOnly If ndtmCheck.DateOnly = ndtmValue.DateOnly Then CheckHolidays = CheckHolidays + 1 Call ndtmNewEnd.AdjustDay(1, True) Call ndtmCheck.AdjustDay(1, True) Else Call ndtmCheck.AdjustDay(1, True) End If Loop Next End Function Function CheckWeekends(varStartDate_p As Variant, intLength_p As Integer) As Integer Dim strSaveDate As String Dim intNewLength As Integer Dim intSaveLength As Integer Dim intCount As Integer Dim ndtmDate As NotesDateTime Dim intDone As Integer Set ndtmDate = varStartDate_p intDone = 0 intNewLength = intLength_p strSaveDate = varStartDate_p.DateOnly Do Until intDone = 1 CheckWeekends = 0 intSaveLength = intNewLength For intCount = 1 To intNewLength If Weekday(ndtmDate.DateOnly) = 1 Or Weekday(ndtmDate.DateOnly) = 7 Then Checkweekends = CheckWeekends + 1 intNewLength = intLength_p + CheckWeekends End If Call ndtmDate.AdjustDay(1,True) Next If intNewLength = intLength_p Then intDone = 1 Else If intSaveLength = intNewLength Then intDone = 1 Else Set ndtmDate = New NotesDateTime(strSaveDate) End If End If Loop End Function

This was first published in July 2001

There are Comments. Add yours.

TIP: Want to include a code block in your comment? Use <pre> or <code> tags around the desired text. Ex: <code>insert code</code>

REGISTER or login:

Forgot Password?
By submitting you agree to receive email from TechTarget and its partners. If you reside outside of the United States, you consent to having your personal data transferred to and processed in the United States. Privacy
Sort by: OldestNewest

Forgot Password?

No problem! Submit your e-mail address below. We'll send you an email containing your password.

Your password has been sent to:

Disclaimer: Our Tips Exchange is a forum for you to share technical advice and expertise with your peers and to learn from other enterprise IT professionals. TechTarget provides the infrastructure to facilitate this sharing of information. However, we cannot guarantee the accuracy or validity of the material submitted. You agree that your use of the Ask The Expert services and your reliance on any questions, answers, information or other materials received through this Web site is at your own risk.