Recurring appointments without counting weekends in Outlook

So here's the deal with the code. You'll want to copy this into a standard module in Outlook, and update the following parts:

-The number of days you wish to increment your appointments goes with "lDaysToAdd". It's currently set to 5
-The last day you'd want an appointment to be created on goes in "dtMaxDay". Spell it out in full format. (ie "December 26, 2006")
-Update the Bank holiday string. Feel free to add as many as you want, but put them in order, and don't forget the "& sDlmtr & " part between each one.

Then save your project. If you've never run code from Outlook before, you may have to set your macro security warnings to a lower level, then exit and restart Outlook to allow the code to run.
Once you have the code in place, open the appointment you wish to copy, then run the code. Just as a note, it does not create them as official "Recurring Appointments", but rather as individual ones.

'--------------------------------------------------------------------------------------------------


Option Explicit
Sub RecurAppointment()
'Macro created 04/22/2006 21:45 by Ken Puls
'Macro Purpose: Copy a currently existing appointment to a certain number
' of days out, ignoring weekends and bank holidays
'
'NOTE: Don't forget to open the instance of the appointment you wish to
' increment before running this code!
Dim iInspct As Inspector
Dim oActiveAppoint As AppointmentItem
Dim oNewAppoint As AppointmentItem
Dim lDaysToAdd As Long
Dim lTempdays As Long
Dim lAryCount As Long
Dim dtCurrentDay As Date
Dim dtMaxDay As Date
Dim aryHolidays() As String
Dim sHolidays As String
Const sDlmtr = "/"
'Enter your repeat cycle, stop date here
lDaysToAdd = 5
dtMaxDay = "May 26, 2006"
'Set your bank holidays here. Don't forget the '& sDlmtr &' between each date,
'make sure to spell out your dates in long hand format, and ensure that all dates
'are in ASCENDING DATE ORDER!
sHolidays = _
"January 2, 2006" & sDlmtr & _
"April 14, 2006" & sDlmtr & _
"April 17 2006" & sDlmtr & _
"May 22, 2006" & sDlmtr & _
"July 3, 2006" & sDlmtr & _
"August 7, 2006" & sDlmtr & _
"September 4, 2006" & sDlmtr & _
"October 9, 2006" & sDlmtr & _
"November 13, 2006" & sDlmtr & _
"December 25, 2006" & sDlmtr & _
"December 26, 2006"
'Send any errors to the error handler to clean up before exit
On Error GoTo ErrHandler
'Split the bank holiday string above into an array for inspection later
aryHolidays = Split(sHolidays, sDlmtr)
'Bind to the active inspector window, or exit routine if an inspector
'window is not active
Set iInspct = ActiveInspector
If iInspct Is Nothing Then GoTo ErrHandler
'Lock in to active appointment and record the start date
Set oActiveAppoint = iInspct.CurrentItem
dtCurrentDay = oActiveAppoint.Start
'Create new appointments
Do Until dtCurrentDay > dtMaxDay
'Find the next day...
For lTempdays = 1 To lDaysToAdd
'Advance other days
Select Case Format((dtCurrentDay), "ddd", vbSunday)
Case Is = "Fri"
'Skip Sat & Sun and go to Monday
dtCurrentDay = dtCurrentDay + 3
Case Is = "Sat"
'This should never happen since Friday will advance
'past weekend days
dtCurrentDay = dtCurrentDay + 2
Case Is = "Sun"
'This should never happen since Friday will advance
'past weekend days
dtCurrentDay = dtCurrentDay + 1
Case Else
'Add one day to move to next day
dtCurrentDay = dtCurrentDay + 1
End Select
'Deal with bank holidays, advancing the date a day if required
For lAryCount = LBound(aryHolidays) To UBound(aryHolidays)
If InStr(1, aryHolidays(lAryCount), _
Format((dtCurrentDay), "mmmm dd, yyyy", vbSunday)) _
Then dtCurrentDay = dtCurrentDay + 1
Next lAryCount
Next lTempdays
'Check that day is not higher than max range
'(Int used to remove fractional days from appointment)
If Int(dtCurrentDay) > Int(dtMaxDay) Then Exit Do
'Create the new appointment
Set oNewAppoint = CreateItem(olAppointmentItem)
With oNewAppoint
.AllDayEvent = oActiveAppoint.AllDayEvent
.Body = oActiveAppoint.Body
.Subject = oActiveAppoint.Subject
.Start = dtCurrentDay
.End = dtCurrentDay + (oActiveAppoint.End - oActiveAppoint.Start)
.Save
End With
Loop
'Clean up and exit
ErrHandler:
Set iInspct = Nothing
End Sub

'-----------------------------------------------------------------------------

by Ken Puls, VBAX