Creating an Outlook Appointment in a shared calendar

[VBAirgin]

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

 

[VBAirgin]

Thanks John,

Unfortunately, I don't have access to the References (greyed out).

Thanks again for your help!

 

[John_w]

In that case, change:

    Dim outApp As Outlook.Application
    Dim outNameSpace As Namespace
    Dim outSharedName As Outlook.Recipient
    Dim outCalendarFolder As MAPIFolder
    Dim outAppointment As AppointmentItem

to:

    Dim outApp As Object
    Dim outNameSpace As Object
    Dim outSharedName As Object
    Dim outCalendarFolder As Object
    Dim outAppointment As Object

 

[John_w]

and add these lines below the Dim statements:

    Const olFolderCalendar = 9
    Const olAppointmentItem = 1
    Const olImportanceNormal = 1

 

[John_w]

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:

    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.

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

 

[noslenwerd]

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:

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]

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

Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar)

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

 

[John_w]

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

       Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar)

Sorry, your Outlook Application object is named olApp, so that line should be:

       Set outCalendarFolder = olApp.Session.GetDefaultFolder(olFolderCalendar)

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

       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:

       Debug.Print objNavFolder.DisplayName

 

[noslenwerd]

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

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.

 

[John_w]

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

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:

    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:

    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]

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!