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

 

[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

 

[noslenwerd]

@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

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'

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]

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!