Excel VBA create appointments for 13th of Month or next working day

[Biz]

Dear All,

I'm trying to use Excel VBA to create appointments in Office 365 on 13th of month or next working day.

Sub SetupRecurringAppointmentFix501()
' Get start date and end date from user input
Dim startDate As Date
Dim endDate As Date
startDate = InputBox("Enter start date (dd/mm/yyyy):")
endDate = InputBox("Enter end date (dd/mm/yyyy):")

' Set up Outlook objects
Dim olApp As Outlook.Application
Dim olApt As Outlook.AppointmentItem
Set olApp = CreateObject("Outlook.Application")
Set olApt = olApp.CreateItem(olAppointmentItem)

' Set up recurring appointment properties
With olApt
    .Subject = "Monthly Meeting"
    .Location = "Conference Room"
    
    ' Find the next available weekday after the 13th day of the month
    Dim nextWeekday As Date
    nextWeekday = DateSerial(Year(startDate), Month(startDate), 13)
    Do Until Weekday(nextWeekday) >= 2 And Weekday(nextWeekday) <= 6
        nextWeekday = nextWeekday + 1
    Loop
    
    .Start = nextWeekday + TimeSerial(10, 0, 0)
    .End = .Start + TimeSerial(4, 0, 0) ' Appointment duration of 4 hour
    .ReminderMinutesBeforeStart = 15 ' Reminder set for 15 minutes before start time
    .ReminderSet = True ' Reminder is enabled
    .BusyStatus = olBusy ' Set appointment status as busy
    .Save ' Save appointment
    .Display
End With

' Set up recurrence pattern
Dim RecurrPat As Outlook.RecurrencePattern
Set RecurrPat = olApt.GetRecurrencePattern
With RecurrPat
    .RecurrenceType = olRecursMonthly ' Recurs monthly
    .Interval = 1 ' Occurs every 1 month
    .DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only
    .PatternStartDate = startDate ' Starts on user-specified start date
    .PatternEndDate = endDate ' Ends on user-specified end date
End With

' Release Outlook objects
Set olApt = Nothing
Set olApp = Nothing
End Sub

I enter Start Date 01/01/2023 and End Date 31/12/2023 it creates appointments on Weekends too. How do I fix this code?
Your help would be greatly appreciated.

Kind Regards


Biz

 

[ceranes]

Hello Biz,

What we need to do is to modify the DayOfWeekMask property to exclude Saturday and Sunday. So basically, we set it to olMonday + olTuesday + olWednesday + olThursday + olFriday, which means the appointment occurs on weekdays only. There are also two exceptions added to exclude Saturdays and Sundays using Exception.Add. The exceptions are added for the first occurrence of the appointment after the 13th day of the month that falls on a Saturday or Sunday.

Give her a try, and let me know if it works!

Best of Luck,

Chris

Sub SetupRecurringAppointmentFix501()
    ' Get start date and end date from user input
    Dim startDate As Date
    Dim endDate As Date
    startDate = InputBox("Enter start date (dd/mm/yyyy):")
    endDate = InputBox("Enter end date (dd/mm/yyyy):")

    ' Set up Outlook objects
    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Set olApp = CreateObject("Outlook.Application")
    Set olApt = olApp.CreateItem(olAppointmentItem)

    ' Set up recurring appointment properties
    With olApt
        .Subject = "Monthly Meeting"
        .Location = "Conference Room"

        ' Find the next available weekday after the 13th day of the month
        Dim nextWeekday As Date
        nextWeekday = DateSerial(Year(startDate), Month(startDate), 13)
        Do Until Weekday(nextWeekday) >= 2 And Weekday(nextWeekday) <= 6
            nextWeekday = nextWeekday + 1
        Loop

        .Start = nextWeekday + TimeSerial(10, 0, 0)
        .End = .Start + TimeSerial(4, 0, 0) ' Appointment duration of 4 hour
        .ReminderMinutesBeforeStart = 15 ' Reminder set for 15 minutes before start time
        .ReminderSet = True ' Reminder is enabled
        .BusyStatus = olBusy ' Set appointment status as busy
        .Save ' Save appointment
        .Display
    End With

    ' Set up recurrence pattern
    Dim RecurrPat As Outlook.RecurrencePattern
    Set RecurrPat = olApt.GetRecurrencePattern
    With RecurrPat
        .RecurrenceType = olRecursMonthly ' Recurs monthly
        .Interval = 1 ' Occurs every 1 month
        .DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only
        .PatternStartDate = startDate ' Starts on user-specified start date
        .PatternEndDate = endDate ' Ends on user-specified end date
    End With

    ' Exclude weekends from the recurrence pattern
    Dim Exceptions As Outlook.Exceptions
    Set Exceptions = RecurrPat.Exceptions
    With Exceptions
        .Add nextWeekday + 5, 0 ' Exclude Saturdays
        .Add nextWeekday + 6, 0 ' Exclude Sundays
    End With

    ' Release Outlook objects
    Set olApt = Nothing
    Set olApp = Nothing
End Sub

 

[Biz]

Hi

I tried and it gets an error "run-time error -659423223 The property for the recurrence type is not valid. Verify your code.
Line highlighted in Yellow

.DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only

Biz

 

[ceranes]

Ok, let me think on this.

 

[ceranes]

What version of Outlook are you using?

 

[Biz]

Using Office 365 at work.

 

[ceranes]

Sub SetupRecurringAppointmentFix501()
    ' Get start date and end date from user input
    Dim startDate As Date
    Dim endDate As Date
    startDate = InputBox("Enter start date (dd/mm/yyyy):")
    endDate = InputBox("Enter end date (dd/mm/yyyy):")

    ' Set up Outlook objects
    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Set olApp = CreateObject("Outlook.Application")
    Set olApt = olApp.CreateItem(olAppointmentItem)

    ' Set up recurring appointment properties
    With olApt
        .Subject = "Monthly Meeting"
        .Location = "Conference Room"

        ' Find the next available weekday after the 13th day of the month
        Dim nextWeekday As Date
        nextWeekday = DateSerial(Year(startDate), Month(startDate), 13)
        Do Until Weekday(nextWeekday) >= 2 And Weekday(nextWeekday) <= 6
            nextWeekday = nextWeekday + 1
        Loop

        .Start = nextWeekday + TimeSerial(10, 0, 0)
        .End = .Start + TimeSerial(4, 0, 0) ' Appointment duration of 4 hour
        .ReminderMinutesBeforeStart = 15 ' Reminder set for 15 minutes before start time
        .ReminderSet = True ' Reminder is enabled
        .BusyStatus = olBusy ' Set appointment status as busy
        .Save ' Save appointment
        .Display
    End With

    ' Set up recurrence pattern
    Dim RecurrPat As Outlook.RecurrencePattern
    Set RecurrPat = olApt.GetRecurrencePattern
    With RecurrPat
        .RecurrenceType = olRecursMonthNth ' Recurs monthly
        .Interval = 1 ' Occurs every 1 month
        .DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only
        .PatternStartDate = startDate ' Starts on user-specified start date
        .PatternEndDate = endDate ' Ends on user-specified end date
    End With

    ' Exclude weekends from the recurrence pattern
    Dim Exceptions As Outlook.Exceptions
    Set Exceptions = RecurrPat.Exceptions
    With Exceptions
        .Add nextWeekday + 5, 0 ' Exclude Saturdays
        .Add nextWeekday + 6, 0 ' Exclude Sundays
    End With

    ' Release Outlook objects
    Set olApt = Nothing
    Set olApp = Nothing
End Sub

Ok. The code is known to work on Outlook 365, 2019, and 2016. Older versions can have issues, which cause this type of error.

I'm going to modify the RecurrentType property and set it to olRecursMonthNth. Let me know if this works, or if you get more errors.

 

[Biz]

It errors out item in yellow.

Sub SetupRecurringAppointmentFix501()
    ' Get start date and end date from user input
    Dim startDate As Date
    Dim endDate As Date
    startDate = InputBox("Enter start date (dd/mm/yyyy):")
    endDate = InputBox("Enter end date (dd/mm/yyyy):")

    ' Set up Outlook objects
    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Set olApp = CreateObject("Outlook.Application")
    Set olApt = olApp.CreateItem(olAppointmentItem)

    ' Set up recurring appointment properties
    With olApt
        .Subject = "Monthly Meeting"
        .Location = "Conference Room"

        ' Find the next available weekday after the 13th day of the month
        Dim nextWeekday As Date
        nextWeekday = DateSerial(Year(startDate), Month(startDate), 13)
        Do Until Weekday(nextWeekday) >= 2 And Weekday(nextWeekday) <= 6
            nextWeekday = nextWeekday + 1
        Loop

        .Start = nextWeekday + TimeSerial(10, 0, 0)
        .End = .Start + TimeSerial(4, 0, 0) ' Appointment duration of 4 hour
        .ReminderMinutesBeforeStart = 15 ' Reminder set for 15 minutes before start time
        .ReminderSet = True ' Reminder is enabled
        .BusyStatus = olBusy ' Set appointment status as busy
        .Save ' Save appointment
        .Display
    End With

    ' Set up recurrence pattern
    Dim RecurrPat As Outlook.RecurrencePattern
    Set RecurrPat = olApt.GetRecurrencePattern
    With RecurrPat
        .RecurrenceType = olRecursMonthNth ' Recurs monthly
        .Interval = 1 ' Occurs every 1 month
        .DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only
        .PatternStartDate = startDate ' Starts on user-specified start date
        .PatternEndDate = endDate ' Ends on user-specified end date
    End With

    ' Exclude weekends from the recurrence pattern
    Dim Exceptions As Outlook.Exceptions
    Set Exceptions = RecurrPat.Exceptions
    With Exceptions
        [COLOR=rgb(247, 218, 100)].Add nextWeekday + 5, 0 ' Exclude Saturdays[/COLOR]
        .Add nextWeekday + 6, 0 ' Exclude Sundays
    End With

    ' Release Outlook objects
    Set olApt = Nothing
    Set olApp = Nothing
End Sub

 

[ceranes]

Sub SetupRecurringAppointmentFix501()
    On Error GoTo ErrorHandler

    ' Get start date and end date from user input
    Dim startDate As Date
    Dim endDate As Date
    startDate = InputBox("Enter start date (dd/mm/yyyy):")
    endDate = InputBox("Enter end date (dd/mm/yyyy):")

    ' Set up Outlook objects
    Dim olApp As Outlook.Application
    Dim olApt As Outlook.AppointmentItem
    Set olApp = CreateObject("Outlook.Application")
    Set olApt = olApp.CreateItem(olAppointmentItem)

    ' Set up recurring appointment properties
    With olApt
        .Subject = "Monthly Meeting"
        .Location = "Conference Room"

        ' Find the next available weekday after the 13th day of the month
        Dim nextWeekday As Date
        nextWeekday = DateSerial(Year(startDate), Month(startDate), 13)
        Do Until Weekday(nextWeekday) >= 2 And Weekday(nextWeekday) <= 6
            nextWeekday = nextWeekday + 1
        Loop

        .Start = nextWeekday + TimeSerial(10, 0, 0)
        .End = .Start + TimeSerial(4, 0, 0) ' Appointment duration of 4 hour
        .ReminderMinutesBeforeStart = 15 ' Reminder set for 15 minutes before start time
        .ReminderSet = True ' Reminder is enabled
        .BusyStatus = olBusy ' Set appointment status as busy
        .Save ' Save appointment
        .Display
    End With

    ' Set up recurrence pattern
    Dim RecurrPat As Outlook.RecurrencePattern
    Set RecurrPat = olApt.GetRecurrencePattern
    With RecurrPat
        .RecurrenceType = olRecursMonthly ' Recurs monthly
        .Interval = 1 ' Occurs every 1 month
        .DayOfWeekMask = olMonday + olTuesday + olWednesday + olThursday + olFriday 'Occurs on weekdays only
        .PatternStartDate = startDate ' Starts on user-specified start date
        .PatternEndDate = endDate ' Ends on user-specified end date
    End With

    ' Exclude weekends from the recurrence pattern
    Dim Exceptions As Outlook.Exceptions
    Set Exceptions = RecurrPat.Exceptions
    With Exceptions
        .Add nextWeekday + 5, 0 ' Exclude Saturdays
        .Add nextWeekday + 6, 0 ' Exclude Sundays
    End With

    ' Release Outlook objects
    Set olApt = Nothing
    Set olApp = Nothing

    Exit Sub

ErrorHandler:
    MsgBox "An error occurred: " & Err.Description
    Set olApt = Nothing
    Set olApp = Nothing
End Sub

Ok. Typically an item highlighted in yellows means there is a problem with the appointment item, such as a missing or invalid property value.
Here is some updated code with built-in error handling, to see if we can identify the issue.

The updated code includes an On Error statement that directs the program to jump to a specified error-handling routine if an error occurs. The error-handling routine displays an error message with a description of the error.

If an error occurs, the appointment item will not be created or saved, and the Outlook objects will be released to avoid any issues with memory allocation. We can use the error message to identify the issue and make any necessary modifications to the code to fix it, hopefully!

 

[Biz]

I got an error. The property for the recurrence type is not valid. Verify your code.

I developed another code which is working well.

Dim aStartTime
Dim ProcName As String
Dim bErrorHandle As Boolean
Const DblSpace As String = vbNewLine & vbNewLine
Const CoName As String = "Job Done!"
Const strSubject As String = "Monthly Reports" '""
Const Appointment_Duration_In_Minutes As Integer = 240
Const nthDay As Integer = 13
Const cReminderMinutes = 15

Sub a_Appointments()
    Dim olApp As Object
    Dim olFolder As Object
    Dim olAppt As Object
    Dim startDate As Date
    Dim endDate As Date
    Dim currentDate As Date
    Dim nextWorkingDay As Date
    Dim publicHolidays As Variant ' Array of NZ public holidays
    Dim totalAppts As Long
    
   
    On Error GoTo ErrHandler
    bErrorHandle = False
   
    '~~> Create an Outlook application object and a calendar folder object
    Set olApp = CreateObject("Outlook.Application")
    Set olFolder = olApp.Session.GetDefaultFolder(9)
   
    '~~> Get start date and end date from user input
    startDate = InputBox("Enter start date (dd/mm/yyyy):")
    endDate = InputBox("Enter end date (dd/mm/yyyy):")
   
    '~~> Start Timer
    aStartTime = Now()
   
    '~~> Speeding Up VBA Code
    Call SpeedUp(False)
   
    '~~> List of New Zealand public holidays
    publicHolidays = Array("1/1/2023", "6/2/2023", "19/4/2023", "22/4/2023", "5/6/2023", "23/10/2023", "25/12/2023", "26/12/2023")
   
    '~~> Loop through each month within the start and end dates
    currentDate = DateSerial(Year(startDate), Month(startDate), nthDay)
   
    totalAppts = 0
    Do While currentDate <= endDate
        '~~> Check if the nth day of the month is a working day (Monday to Friday) and not a public holiday
        If Weekday(currentDate) <> vbSaturday And Weekday(currentDate) <> vbSunday And _
        Not IsInArray(CDate(currentDate), publicHolidays) Then
            '~~> Create the appointment for the 13th day
            Set olAppt = olFolder.Items.Add("IPM.Appointment")
            With olAppt
                .subject = strSubject
                .Start = currentDate + TimeSerial(10, 0, 0)
                .Duration = Appointment_Duration_In_Minutes '~~> Appointment duration in minutes
                .ReminderMinutesBeforeStart = cReminderMinutes '~~> Set a reminder for 15 minutes before the appointment
                .Save
                totalAppts = totalAppts + 1
            End With
        Else
            '~~> Find the next working day that is not a public holiday
            nextWorkingDay = currentDate
            Do While Weekday(nextWorkingDay) = vbSaturday Or Weekday(nextWorkingDay) = vbSunday Or _
                IsInArray(CDate(nextWorkingDay), publicHolidays)
                nextWorkingDay = DateAdd("d", 1, nextWorkingDay)
            Loop
            '~~> Create the appointment for the next working day
            Set olAppt = olFolder.Items.Add("IPM.Appointment")
            With olAppt
                .subject = strSubject '"Meeting on " & Format(nextWorkingDay, "dd/mm/yyyy")
                .Start = nextWorkingDay + TimeSerial(10, 0, 0)
                .Duration = Appointment_Duration_In_Minutes '~~> Appointment duration in minutes
                .ReminderMinutesBeforeStart = cReminderMinutes '~~> Set a reminder for 15 minutes before the appointment
                .Save
                totalAppts = totalAppts + 1
            End With
        End If
        currentDate = DateAdd("m", 1, currentDate)
        Loop '~~> Add this line to close the Do While loop
       
       
BeforeExit:
        '~~> Remove items from memory
        Set olApp = Nothing
        Set olFolder = Nothing
        Set olAppt = Nothing
       
        '~~> Speeding Up VBA Code
        Call SpeedUp(True)
       
        If bErrorHandle = False Then
           
            '~~> No Errors
            MsgBox "Time taken: " & Format(Now() - aStartTime, "h:mm:ss") & DblSpace _
            & "Created " & totalAppts & " appointments with the subject line: " & strSubject & DblSpace _
            & " You're good to go!" & DblSpace & _
            CoName & Chr(32) & Chr(169) & Chr(32) & Year(Date), vbInformation, "Excellent"
           
        End If
       
        Exit Sub
ErrHandler:
        '~~> Error Occurred
        bErrorHandle = True
        ProcName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
        MsgBox "Procedure: - " & ProcName & DblSpace & Err.Description, vbCritical, "Oops I did it again...."
        Resume BeforeExit
End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i As Integer
   
    IsInArray = False
   
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True
            Exit For
        End If
    Next
   
End Function

'#### SpeedUp (False) - Speeds the VBA Code #####
'#### SpeedUp (True) - Slows down the VBA Code ####
Public Function SpeedUp(Optional bSpeed As Boolean = True)
    With Application
        .ScreenUpdating = bSpeed 'Prevent screen flickering
        .Calculation = IIf(bSpeed, xlAutomatic, xlCalculationManual) 'Preventing calculation
        .DisplayAlerts = bSpeed 'Turn OFF alerts
        .EnableEvents = bSpeed 'Prevent All Events
        .Cursor = IIf(bSpeed, xlDefault, xlWait) 'Prevent Hour Glass
        .StatusBar = IIf(bSpeed, vbNullString, "Please wait...")
        '.Application.Interactive = bSpeed 'Block all input from the keyboard and mouse
    End With
End Function

Kind Regards


Biz