About This Code
Brief Description:
Calculate date ranges excluding weekends and company holidays
Contributor:
Andrew Jones
Last Modified:
17 Jun 2002
OpenNTF Disclaimer
All of the program code and information presented in the OpenNTF.org Code Bin are provided "as-is", and should be used at your own risk. OpenNTF.org make no express or implied warranty about anything in the Code Bin, and OpenNTF.org will not be responsible or liable for any damage caused by the use or misuse of anything from this site. OpenNTF.org makes no guarantees about anything. Please thoroughly test all of the knowledge and code you find here before you attempt to use them in your production environment.
Code / Description
'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
Usage / Example