VBA to create an Outlook calendar entry

[Adman123]

Hi Everyone,

I'm hoping you could help. I'd like to create an Outlook calendar meeting request each time a spreadsheet is saved, the meeting requests needs to be added to a shared mailbox so that all users that have access then see the meeting invite.
So far I have this setup so it adds an entry to my personal calendar but that's not quite what I want.
I'm no vba expert by a long shot. Any help is greatly appreciated.
Code below, thanks.

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2021") 'define your sheet!
  
    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")

    'define constants if using late binding
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 3

    Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olApp.CreateItem(olAppointmentItem)
                .Subject = ws.Cells(iRow, 4).Value
                .Start = ws.Cells(iRow, 3).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Save
            End With
            ws.Cells(iRow, 3).Interior.ColorIndex = 50
        End If

        iRow = iRow + 1
    Loop
End Sub

 

[Adman123]

Hi,

Anybody able to assist here please?

Thanks in advance

 

[Adman123]

Even if I can use the Recipient.Add function, that should be enough. I'm just unaware how to add it to this code. Any help would be great?

 

[John_w]

See if the posts in this thread help you. This link is to the post with the final working answer.

Creating an Outlook Appointment in a shared calendar

Hi all, I am trying to write a VBA to create an Outlook Appointment in a shared calendar. The below code creates an appointment, but in my own default calendar. I would appreciate any help anyone can provide, as I am struggle to find an answer. Sub CalendarEntry() Dim OutApp As Object Dim...

www.mrexcel.com

 

[Adman123]

See if the posts in this thread help you. This link is to the post with the final working answer.

Creating an Outlook Appointment in a shared calendar

Hi all, I am trying to write a VBA to create an Outlook Appointment in a shared calendar. The below code creates an appointment, but in my own default calendar. I would appreciate any help anyone can provide, as I am struggle to find an answer. Sub CalendarEntry() Dim OutApp As Object Dim...

www.mrexcel.com

Hi John,

Thanks for the reply. I think this could help me however, as I'm unfamiliar with VBA I'm unsure how to amend my code to enable this to work. I also think using Recipient.Add would work, but again I'm not entirely sure how to add this to my code.

Any further help would be greatly appreciated.

Thanks in advance

 

[Adman123]

Hey,

I've sort of managed to get this working however, the one problem I now have is that it'll only create the calendar entry for the last line (maybe something to do with the loop?). If you can take a look at my code below and suggest what might be causing this then that'd be appreciated:

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
  
    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    Dim olAppItem As Outlook.AppointmentItem
    Dim myRequiredAttendee As Outlook.Recipient
        
    'define constants if using late binding
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
        
    Set olAppItem = olRecItems.Items.Add(olAppointmentItem)

    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 3

    Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)
        

        If olFilterRecItems.Count = 0 Then 'if subject does not exist
            With olAppItem
            Set myRequiredAttendee = .Recipients.Add("shared email address")
            myRequiredAttendee.Type = olRequired
                .MeetingStatus = olMeeting
                .ReminderMinutesBeforeStart = 30
                .Subject = ws.Cells(iRow, 4).Value
                .Start = ws.Cells(iRow, 3).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Send
            End With
            ws.Cells(iRow, 3).Interior.ColorIndex = 50
        End If

        iRow = iRow + 1
    Loop
End Sub

 

[John_w]

It looks like you're creating only 1 calendar entry (appointment) above the loop (Set olAppItem = olRecItems.Items.Add(olAppointmentItem)) and overwriting its settings inside the loop, so that it ends up with the settings from the last row. To create multiple entries move that line inside the loop, like this:

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("2020") 'define your sheet!
  
    Dim olApp As Object  'create outlook application
    Set olApp = CreateObject("Outlook.Application")

    Dim olNS As Object 'get namespace
    Set olNS = olApp.GetNamespace("MAPI")
    
    Dim olAppItem As Outlook.AppointmentItem
    Dim myRequiredAttendee As Outlook.Recipient
        
    'define constants if using late binding
    Const olFolderCalendar As Long = 9
    Const olAppointmentItem As Long = 1

    Dim olRecItems As Object 'get all appointments
    Set olRecItems = olNS.GetDefaultFolder(olFolderCalendar)
        
    Dim strFilter As String  'filter for appointments
    Dim olFilterRecItems As Object 'filtered appointments

    Dim iRow As Long
    iRow = 3

    Do Until Trim$(ws.Cells(iRow, 3).Value) = vbNullString
        'filter appointments for subject
        strFilter = "[Subject] = '" & Trim$(ws.Cells(iRow, 4).Value) & "'"
        Set olFilterRecItems = olRecItems.Items.Restrict(strFilter)        

        If olFilterRecItems.Count = 0 Then 'if subject does not exist

            Set olAppItem = olRecItems.Items.Add(olAppointmentItem)

            With olAppItem
            Set myRequiredAttendee = .Recipients.Add("shared email address")
            myRequiredAttendee.Type = olRequired
                .MeetingStatus = olMeeting
                .ReminderMinutesBeforeStart = 30
                .Subject = ws.Cells(iRow, 4).Value
                .Start = ws.Cells(iRow, 3).Value
                .AllDayEvent = True
                .BusyStatus = 5
                .ReminderSet = True
                .Send
            End With
            ws.Cells(iRow, 3).Interior.ColorIndex = 50

        End If

        iRow = iRow + 1
    Loop
End Sub

 

[Adman123]

Yes that was exactly it, working as planned now thanks a lot