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]

See if you can incorporate this into your code. Untested because I don't have a shared mailbox/calendar.

Replace everything below the CreateObject line with this, changing the shared mailbox email address to suit.

    Dim outNameSpace As Object 'Namespace
    Dim outSharedName As Object 'Outlook.Recipient
    Dim outCalendarFolder As Object 'MAPIFolder
    Dim outAppointment As Object 'AppointmentItem
    Dim SharedMailboxEmail As String
    
    SharedMailboxEmail = "sharedEmail@youraddress.com"  'CHANGE THIS
        
    Set outNameSpace = outApp.GetNamespace("MAPI")    
    Set outSharedName = outNameSpace.CreateRecipient(SharedMailboxEmail)
    Set outCalendarFolder = outNameSpace.GetSharedDefaultFolder(outSharedName, 9) '9=olFolderCalendar
    Set outAppointment = outCalendarFolder.Items.Add(1) '1=olAppointmentItem
    With outAppointment
        .Subject = "The subject"
        .Start = Now + 1 'this time tomorrow
        .Duration = 60
        .Importance = olImportanceNormal
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 15
        .ReminderPlaySound = False
        .Save
    End With

I would remove the On Error Resume Next line whilst testing.

PS - please put code inside code tags - the # icon in the message editor - [CODE]code here[/CODE]

 

[VBAirgin]

Hi John

Thanks ever so much for the response, as you can probably tell am a true novice here. I presume in the following code, I need to replace your notes with data, but I truly don't know what or where to find this info.

    Dim outNameSpace As Object 'Namespace
    Dim outSharedName As Object 'Outlook.Recipient
    Dim outCalendarFolder As Object 'MAPIFolder
    Dim outAppointment As Object 'AppointmentItem
    Dim SharedMailboxEmail As String

If this is not the case, the code is falling down at the following line.

Set outCalendarFolder = outNameSpace.GetSharedDefaultFolder(outSharedName, 9) '9=olFolderCalendar

Thanks again,
Simon

 

[John_w]

You don't need to change anything on those Dim lines. Since your code indicated that you're using late binding of the Outlook objects, I also used the generic Object type and shown the actual Outlook data type after it. What is the exact error on the GetSharedDefaultFolder line?

Did you change the SharedMailboxEmail string to the correct email address for your shared calendar?

Here is the complete version of my code, to create a single calendar appointment. This time I've declared variables (the Dim statements) using the proper Outlook data type and in order to do this you must set a reference (via Tools->References in the VBA editor) to Microsoft Outlook nn.0 Object Library, otherwise the code won't compile or run. The code starts Outlook if it isn't running.

Public Sub Create_Calendar_Appointment()

    Dim outApp As Outlook.Application
    Dim outNameSpace As Namespace
    Dim outSharedName As Outlook.Recipient
    Dim outCalendarFolder As MAPIFolder
    Dim outAppointment As AppointmentItem
    Dim SharedMailboxEmail As String
    
    SharedMailboxEmail = "sharedEmail@youraddress.com"  'CHANGE THIS
    
    If Not IsOutlookRunning Then
        CreateObject("WScript.Shell").Run "outlook.exe", 3, False
        Set outApp = CreateObject("Outlook.Application")
    Else
        Set outApp = GetObject(, "Outlook.Application")
    End If
    
    Set outNameSpace = outApp.GetNamespace("MAPI")
    Set outSharedName = outNameSpace.CreateRecipient(SharedMailboxEmail)
    Set outCalendarFolder = outNameSpace.GetSharedDefaultFolder(outSharedName, olFolderCalendar)
    
    Set outAppointment = outCalendarFolder.Items.Add(olAppointmentItem)
    With outAppointment
        .Subject = "The subject"
        .Start = Now + 1 'this time tomorrow
        .Duration = 60
        .Importance = olImportanceNormal
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 15
        .ReminderPlaySound = False
        .Save
    End With

    Set outAppointment = Nothing
    Set outCalendarFolder = Nothing
    Set outNameSpace = Nothing
    Set outApp = Nothing

End Sub


Private Function IsOutlookRunning() As Boolean
    Dim Outlook As Object
    Set Outlook = Nothing
    On Error Resume Next
    Set Outlook = GetObject(, "Outlook.Application")
    On Error GoTo 0
    IsOutlookRunning = Not Outlook Is Nothing
End Function

If you have changed the shared mail address correctly and still get the same error on the GetSharedDefaultFolder line, try replacing it with one of these:

    Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("Name of shared calendar")
    Set outCalendarFolder = outApp.Session.GetDefaultFolder(olFolderCalendar).Parent.Parent.Folders("Shared account name").Folders("Name of shared calendar")

changing the parts in quotes as required.

 

[VBAirgin]

Thanks again for your help.

Using the original code you sent me, I have tried again, and I am getting the following error message.

On line: Set outNameSpace = outApp.GetNamespace("MAPI")

 

[VBAirgin]

Apparently I can't paste pictures either :D

The error message reads:

Run-time error '4':
Object Required

 

[John_w]

Try the code in post #4 .

 

[VBAirgin]

Hi,

I've just tried that one, and I'm getting an error on the first line (Dim outApp As Outlook.Application):

Compile Error:
User-defined type not defined

You will have to forgive me, I am an absolute novice here.

 

[John_w]

.... you must set a reference (via Tools->References in the VBA editor) to Microsoft Outlook nn.0 Object Library, otherwise the code won't compile or run.

In Excel's VBA editor, click Tools on the menu, then References..., scroll down the list of Available References and find Microsoft Outlook nn.0 Object Library (where nn.0 is your version of Outlook) and tick the box next to it, then click OK to close the dialogue.

 

[VBAirgin]

Thanks John,

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

Thanks again for your help!