Creating an Outlook Appointment in a shared calendar

VBAirgin

New Member
Joined
Oct 17, 2018
Messages
6
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 OutMail As Object
Dim duedate As String
Dim currentrow As String
Dim currentsheet As String
Dim owner As String

currentsheet = ActiveSheet.Name
duedate = Range("B1")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(1)
On Error Resume Next
With OutMail
.RequiredAttendees = "test@email.co.uk"
.Subject = Range("B2") & Range("C2") & Range("D2") & Range("E2") & Range("F2") & Range("G2") & Range("H2") & Range("I2")
.Importance = True
.Start = "8:00 AM" & duedate
.End = "9:00 AM" & duedate
.ReminderMinutesBeforeStart = 0
.Body = Range("B3")
.Display
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Emy
End Sub
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,088
In that case, change:
Code:
    Dim outApp As Outlook.Application
    Dim outNameSpace As Namespace
    Dim outSharedName As Outlook.Recipient
    Dim outCalendarFolder As MAPIFolder
    Dim outAppointment As AppointmentItem
to:
Code:
    Dim outApp As Object
    Dim outNameSpace As Object
    Dim outSharedName As Object
    Dim outCalendarFolder As Object
    Dim outAppointment As Object
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,088
and add these lines below the Dim statements:
Code:
    Const olFolderCalendar = 9
    Const olAppointmentItem = 1
    Const olImportanceNormal = 1
 

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
80
Office Version
  1. 365
@John_w brilliant stuff.

Sorry for bumping an old thread but I am trying to achieve the same thing. I get an I am unable to get the invites to actual send from the shared inbox. I get the below error on line 46

1600186798901.png


Here is my adapted code below. Any ideas? Is the calendar name exactly as it appears in my tray: "Calendar - DSSTest' , or is Calendar inherent and it's simply 'DSSTest'

VBA Code:
Sub DSSEduCollab()
Dim olApp As Outlook.Application
Dim outNameSpace As Namespace
Dim outSharedName As Outlook.Recipient
Dim outCalendarFolder As MAPIFolder
Dim olAppItem As Outlook.AppointmentItem
Dim mysub, myDate, myStart, myStart2, attendees, myEnd, alignedDSS, eduDescription, webexLink, distName, SharedMailboxEmail As String
Dim r As Long
Dim eduSheet As Worksheet

SharedMailboxEmail = "DSSTest@companyname.com"
Set eduSheet = ThisWorkbook.Sheets("DSSEDU")

r = 2 ' first row with appointment data in the active worksheet

On Error Resume Next
Worksheets("Schedule").Activate
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
    If olApp Is Nothing Then
    On Error Resume Next
    Set olApp = CreateObject("Outlook.Application")
    On Error GoTo 0
        If olApp Is Nothing Then
        MsgBox "Outlook is not available!"
        Exit Sub
        End If
    End If


    While Len(eduSheet.Cells(r, 2).Text) <> 0
    distName = eduSheet.Cells(r, 17) 'district name'
    mysub = eduSheet.Cells(r, 1) & " | " & distName 'subject of meeting'
    myDate = eduSheet.Cells(r, 5).Value ' calendar date of meeting'
    myStart = eduSheet.Cells(r, 6).Value ' start time of meeting'
    myStart2 = myDate & " " & myStart ' combine start date and time'
    myDuration = eduSheet.Cells(r, 7).Value 'duration'
    myEnd2 = myDate & " " & myEnd 'combine end date and time'
    attendees = eduSheet.Cells(r, 12).Value & "; " & eduSheet.Cells(r, 13).Value & "; " & eduSheet.Cells(r, 14).Value
    alignedDSS = "Your aligned specialists for this month will be " & eduSheet.Cells(r, 8).Value & " from " & eduSheet.Cells(r, 9).Value & " and " & eduSheet.Cells(r, 10).Value & " from " & eduSheet.Cells(r, 11).Value
    eduDescription = eduSheet.Cells(r, 3).Value
    webexLink = "******** " & "To join the meeting visit the following link: " & vbNewLine & "******** " & eduSheet.Cells(r, 15).Value

    Set outNameSpace = olApp.GetNamespace("MAPI")
    Set outSharedName = outNameSpace.CreateRecipient(SharedMailboxEmail)
    Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("DSSTest@companyname.com").Folders("DSSTest")
    Set olAppItem = olApp.CreateItem(olAppointmentItem)    ' creates a new appointment

        With olAppItem
            ' set default appointment values
            .Location = eduSheet.Cells(r, 2).Value
            .ReminderSet = True
            .BusyStatus = olBusy
            .RequiredAttendees = attendees
            On Error Resume Next
            .Start = myStart2 'Set meeting start time'
            .Duration = myDuration
            .Subject = mysub
            .Body = eduDescription & vbNewLine & alignedDSS & vbNewLine & vbNewLine & webexLink
            .ReminderSet = True
            .ReminderMinutesBeforeStart = 15
            .BusyStatus = olBusy
            On Error GoTo 0
            .Display ' saves the new appointment to the default folder
        End With
    r = r + 1
    Wend
Set olAppItem = Nothing
Set outCalendarFolder = Nothing
Set outNameSpace = Nothing
Set olApp = Nothing
MsgBox "The times shown in the Outlook Invites created are CST. Be sure to adjust times accordingly.", vbExclamation
MsgBox "PLEASE NOTE" & vbNewLine & vbNewLine & "The meetings created DO NOT automatically have a recurrence set." & vbNewLine & vbNewLine & "You must manually create a recurring meeting", vbExclamation
End Sub
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,088
Is the calendar name exactly as it appears in my tray: "Calendar - DSSTest' , or is Calendar inherent and it's simply 'DSSTest'
In my test the 'Calendar - ' part is omitted from the calendar name so it should be 'DSSTest'.
Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("DSSTest@companyname.com").Folders("DSSTest")
The problem with an 'all or nothing' line like that with multiple objects in a single statement is that you don't know which part caused the 'Object required' error. Try breaking it down object by object like this, checking in the Debugger that after each line the outCalendarFolder object is not Nothing. If outCalendarFolder is Nothing then the next line which references outCalendarFolder will cause the 'Object required' error. Replace the single line with these lines:
VBA Code:
    Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar)
    Set outCalendarFolder = outCalendarFolder.Parent
    Set outCalendarFolder = outCalendarFolder.Parent
    Set outCalendarFolder = outCalendarFolder.Folders("DSSTest@companyname.com")
    Set outCalendarFolder = outCalendarFolder.Folders("DSSTest")
You may find this Outlook VBA macro useful. It lists all the shared calendars to the VBA immediate window (View -> Immediate Window in the VBA editor). I can't test it because I don't have any shared calendars.
VBA Code:
Public Sub List_Shared_Calendars()
    Dim objExpCal As Outlook.Explorer
    Dim objNavMod As Outlook.CalendarModule
    Dim objNavGroup As Outlook.NavigationGroup
    Dim objNavFolder As Outlook.NavigationFolder
    Dim objFolder As Outlook.Folder
    Set objExpCal = Session.GetDefaultFolder(olFolderCalendar).GetExplorer
    Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
    Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
    For Each objNavFolder In objNavGroup.NavigationFolders
        Debug.Print objNavFolder.DisplayName, objNavFolder.Folder.folderPath, objNavFolder.Parent
    Next
    Set objNavMod = Nothing
    Set objNavGroup = Nothing
    Set objNavFolder = Nothing
    Set objFolder = Nothing
End Sub
 
Last edited:

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
80
Office Version
  1. 365

ADVERTISEMENT

Appreciate the detailed reply. Going to dig into the first portion now.

As to the latter chunk of code, getting runtime error 5 on this line:

VBA Code:
Debug.Print objNavFolder.DisplayName, objNavFolder.Folder.FolderPath, objNavFolder.Parent

And this is all that pops up in the immediate window

United States holidays \\myemail2@company.com\Calendar\United States holidays
 

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
80
Office Version
  1. 365
As to the first portion, runtime error '424' started right at the first new line:

Code:
Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar)

I also double checked my reference libraries and looks good to me.

1600282762084.png
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,088

ADVERTISEMENT

As to the first portion, runtime error '424' started right at the first new line:

VBA Code:
       Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar)
Sorry, your Outlook Application object is named olApp, so that line should be:
VBA Code:
       Set outCalendarFolder = olApp.Session.GetDefaultFolder(olFolderCalendar)

As to the latter chunk of code, getting runtime error 5 on this line:

VBA Code:
       Debug.Print objNavFolder.DisplayName, objNavFolder.Folder.FolderPath, objNavFolder.Parent
I don't have a shared calendar to test with , so it could be that some of those properties aren't defined/available, so try just:

VBA Code:
       Debug.Print objNavFolder.DisplayName
 

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
80
Office Version
  1. 365
I think we're maybe getting to the root of the problem. So for the code to display all the calendar folders. Looks like it only displays the United States Holidays folder.

Here is where I am getting an error

1600350095022.png


And here is a screenshot of all my calendars. Perhaps the DSSTest calendar isn't technically a "shared" calendar?

Green outline is what we are shooting for, and yellow is what is shows above in the immediate window.

1600351223531.png
 

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
7,088
So for the code to display all the calendar folders. Looks like it only displays the United States Holidays folder.

Here is where I am getting an error

1600350095022.png


And here is a screenshot of all my calendars. Perhaps the DSSTest calendar isn't technically a "shared" calendar?
The above macro is meant to display only shared calendars. I don't know, but maybe shared calendars don't have a Parent. Therefore try deleting the yellow line.

Yes, it looks like your DSSTest calendar isn't a shared calendar. Replace these lines in your code above:

VBA Code:
    Set outNameSpace = olApp.GetNamespace("MAPI")
    Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("DSSTest@companyname.com").Folders("DSSTest")
    Set olAppItem = olApp.CreateItem(olAppointmentItem)    ' creates a new appointment

    With olAppItem
with:
VBA Code:
    Set outNameSpace = olApp.GetNamespace("MAPI")
    'Start at Namespace and get the DSSTest/DSSTest@companyname.com data file folder (whichever works)
    'Either
    Set outCalendarFolder = outNameSpace.Folders("DSSTest")
    'or
    Set outCalendarFolder = outNameSpace.Folders("DSSTest@companyname.com")
    
    'Get the calendar within DSSTest/DSSTest@companyname.com
    Set outCalendarFolder = outCalendarFolder.Folders("Calendar")
    'Confirm correct calendar
    Debug.Print outCalendarFolder.Name, outCalendarFolder.FolderPath

    'Create new appointment in DSSTest calendar
    Set olAppItem = outCalendarFolder.Items.Add(olAppointmentItem)

    With olAppItem
 

noslenwerd

Board Regular
Joined
Nov 12, 2019
Messages
80
Office Version
  1. 365
Perfect!! That did the trick.

Thank you so much for your help. You have helped our org save countless hours on monthly invites that we send out.

Have an excellent weekend, John_w!
 

Forum statistics

Threads
1,148,364
Messages
5,746,272
Members
424,002
Latest member
anon341

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