Thanks again Rod but it was a bit more complicated as some days have
different working hours. I eventually got a function to work. It is listed
below. You pass it two dates and it calculates the working days between and
returns the number. So far it is testing without a problem.
'::::::::::::::::::: FUNCTION TO FIND THE NUMBER OF WORKING DAYS BETWEEN TWO
DATES :::::::::::::::::
Function funCalcWorkingDays(StartDate As Date, EndDate As Date)
Dim objMSProject As MSProject.Application '
Application Object
Dim objMSProjectDoc As MSProject.Project ' Project
Object
Dim objMSProjectCal As Calendar ' Calendar
Object
Dim strProjectName As String ' Path to
the project (from the form)
Dim WorkingDays As Integer ' Number of
working days
Dim dteCurrentlyChecking As Date ' The date
currently being checked
Dim intCheckYear As Integer ' The year
currently being checked
Dim intCheckMonth As Integer ' The month
currently being checked
Dim intCheckDay As Integer ' The day
currently being checked
Dim dteStart As Date ' The start
date of the period to check
Dim intStartYear As Integer ' The year
of the start date
Dim intStartMonth As Integer ' The month
of the start date
Dim intStartDay As Integer ' The day of
the start date
Dim dteEnd As Date ' The end
date of the period to check
Dim intEndYear As Integer ' The year
of the end date
Dim intEndMonth As Integer ' The month
of the end date
Dim intEndDay As Integer ' The day of
the end date
Dim intCounter As Integer ' Counter
for the for/next loop
WorkingDays = 0 ' Initialise
the days
dteStart = StartDate ' The start
date parameter passed to the function
dteEnd = EndDate ' The end
date parameter passed to the function
intStartYear = Year(dteStart) ' The year
of the start date
intStartMonth = Month(dteStart) ' The month
of the start date
intStartDay = Day(dteStart) ' The day of
the start date
intEndYear = Year(dteEnd) ' The year
of the end date
intEndMonth = Month(dteEnd) ' The month
of the end date
intEndDay = Day(dteEnd) ' The day of
the end date
' Set up the
criteria to start counting working days
intCheckMonth = intStartMonth ' Start
checking from the start date - month
intCheckYear = intStartYear ' Start
checking from the start date - year
intCheckDay = intStartDay ' Start
checking from the start date - day
strProjectName = Me.Path ' The
location of the project file
Set objMSProjectDoc = GetObject(strProjectName) ' Create the
project object
Set objMSProjectCal = objMSProjectDoc.BaseCalendars(1) ' Create the
base calendar object
' Read each day record and decide if it is a working day. If it is
increment the integer WorkingDays by one.
CalcWorkingDays:
With objMSProjectCal.Years(intCheckYear).Months(intCheckMonth) ' The
year and month to check
For intCounter = intCheckDay To .Days.Count ' Start
at the start day, or if not the first month
' start
at 1
If .Days(intCounter).Working = True Then ' Is a
working day
' Create
the date
dteCurrentlyChecking = DateSerial(intCheckYear,
intCheckMonth, intCounter)
If dteCurrentlyChecking > dteEnd Then ' Check
it is not past the end date
funCalcWorkingDays = WorkingDays ' End
of checking
GoTo funCalcWorkingDays_Exit ' Clean
up before exiting
Else
WorkingDays = WorkingDays + 1 '
Increment the counter by 1
End If
End If
Next intCounter ' Loop back
and read the next record
End With
NextMonth: ' Check if
there is another month to check
intCounter = 0 ' Initialise
the counter
intCheckDay = 1 ' First day of next
month
intCheckMonth = intCheckMonth + 1 ' Increment the
month by one
If intCheckMonth = 13 Then ' Last month checked
was December
intCheckMonth = 1 ' Next month to
check is January
intCheckYear = intCheckYear + 1 ' Increase the year
by one
End If
If intEndYear > intCheckYear Then ' Date range spans
two years
GoTo funCalcWorkingDays_Exit ' Clean up and exit
End If
GoTo CalcWorkingDays ' Check the next month
funCalcWorkingDays_Exit: ' Close Project and
initialize fields
On Error Resume Next
objMSProject.DocClose ' Close the project
file
objMSProject.Quit ' Quit MSP
Exit Function ' End the function
funCalcWorkingDays_Error: ' Error Handling
MsgBox Err.Description
Resume Next
End Function
