VBA to create an Outlook calendar entry

Adman123

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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.
VBA Code:
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
 

Excel Facts

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college

Adman123

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Hi,

Anybody able to assist here please?

Thanks in advance
 

Adman123

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,083
See if the posts in this thread help you. This link is to the post with the final working answer.

 

Adman123

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

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

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

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,083
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:

VBA Code:
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

New Member
Joined
Jun 4, 2021
Messages
6
Office Version
  1. 365
Platform
  1. Windows
Yes that was exactly it, working as planned now thanks a lot
 

Forum statistics

Threads
1,147,560
Messages
5,741,835
Members
423,690
Latest member
VikMka

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top