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

 

[dramaasetterr]

Hi John,

I am a super newbie to VBA and could really use some help that definitely is very close to the issues stated here. I currently have a worksheet that pulls the data on any row with an X in the first column to another tab, and then at the click of a button, creates appointments based on the information in the columns. However, it is creating them in a personal mailbox and not the shared mailbox for it to be seen by my entire team. Please help.

Sub SendInvite()
'Send calendar invites
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.EnableEvents = False

Dim OutApp As Object
Dim OutMail As Object
Dim myRequiredAttendee As Object


Set OutApp = CreateObject("Outlook.Application")

r = 2

Do Until Trim(Cells(r, 1).Value) = ""

Set OutMail = OutApp.CreateItem(1)
OutMail.MeetingStatus = 1
OutMail.RequiredAttendees = "qowens@weltmannlighting.com"
OutMail.Subject = Cells(r, "C").Value & " - Delivery - POD#" & Cells(r, "P").Value
OutMail.Start = Cells(r, "D").Value & " " & TimeValue(Cells(r, "E").Value)
OutMail.Location = Cells(r, "K").Value
OutMail.Body = Cells(r, "F").Value & " // Contact: " & Cells(r, "J").Value
OutMail.AllDayEvent = False
OutMail.BusyStatus = 0
OutMail.ReminderSet = True
OutMail.send

Set OutMail = Nothing

MsgBox "Invite Sent", vbInformation

r = r + 1

Loop

endmacro:
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True

End Sub

 

[John_w]

However, it is creating them in a personal mailbox and not the shared mailbox

Please follow the posts in this thread from post #13 - there should be enough diagnostic/debugging code to help you to find/reference the shared mailbox and its associated shared calendar.

If you need more help please start your own thread.

 

[GreyMist]

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!

Hi,
Was wondering if you could share the end result of your VBA code as I find myself still stuck on the back and forth of this thread. I too am trying access a Calendar that is not under my shared but "Calendars". I do not wish to send from my personal but from the other Calendar instead.

thank you!

 

[John_w]

Was wondering if you could share the end result of your VBA code as I find myself still stuck on the back and forth of this thread.

This was the final code in accordance with @noslenwerd's request starting at post #13.

This Excel VBA macro uses early binding of the Outlook Object Library, so you must set a reference to Microsoft Outlook nn.0 Object Library, via Tools-> References in the VBA editor, where nn.0 is your Outlook version.

Private Sub Outlook_Appointment_in_Shared_Calendar()

    Dim olApp As Outlook.Application
    Dim outNameSpace As Namespace
    Dim outSharedName As Outlook.Recipient
    Dim outCalendarFolder As MAPIFolder
    Dim olAppItem As Outlook.AppointmentItem
    Dim SharedMailboxEmail As String

    SharedMailboxEmail = "DSSTest@companyname.com"

    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
  
    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
        ' set default appointment values
        .Location = "XXXX"
        .ReminderSet = True
        .BusyStatus = olBusy
        .RequiredAttendees = "XXXX"
        .MeetingStatus = olMeeting
        On Error Resume Next
        .Start = Date
        .Duration = 60
        .Subject = "Subject"
        .Body = "Body text"
        .ReminderSet = True
        .ReminderMinutesBeforeStart = 15
        .BusyStatus = olBusy
        On Error GoTo 0
        .Display ' saves the new appointment to the default folder
    End With
       
End Sub

Please start a new thread if you need more help.

 

[GreyMist]

This was the final code in accordance with @noslenwerd's request starting at post #13.

Hi John,
thank you. I was able to piece together my code and it works. Below is what I had to do to set up multiple requests at once from the shared calendar

[/CODE]
Private Sub Outlook_Appointment_in_Shared_Calendar()


Dim i As Long
Dim R As Range
Dim olApp As Object
Dim outNameSpace As Object
Dim outSharedName As Object
Dim outCalendarFolder As Object
Dim olAppItem As Object
Dim olfolder As Object
Dim SharedMailboxEmail As String

SharedMailboxEmail = "Email Address added here in quotes"

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

Set outNameSpace = olApp.GetNamespace("MAPI")

'Pick the Calendar folder under shared mailbox
Set olfolder = olApp.GetNamespace("MAPI").PickFolder

'Start at Namespace and get the shared calendar data file folder
Set outCalendarFolder = outNameSpace.Folders("Name of the Calendar folder here")

'Get the calendar within the shared calendar folder
Set outCalendarFolder = outCalendarFolder.Folders("Calendar")

'Confirm correct calendar
Debug.Print outCalendarFolder.Name, outCalendarFolder.FolderPath

'Create new appointment shared calendar
Set R = Range("A2:H5")
For i = 1 To R.Rows.Count
If R.Cells(i, 7).Value <> "" Then
Set olAppItem = olfolder.Items.Add
Debug.Print R.Cells(i, 1).Value
olAppItem.Subject = R.Cells(i, 1).Value
olAppItem.RequiredAttendees = R.Cells(i, 2).Value
olAppItem.Location = R.Cells(i, 3).Value
olAppItem.Start = R.Cells(i, 4).Value
olAppItem.Duration = R.Cells(i, 5).Value
If Trim(R.Cells(i, 6).Value) = "" Then
olAppItem.BusyStatus = 2
Else
olAppItem.BusyStatus = R.Cells(i, 6).Value
End If
If R.Cells(i, 7).Value > 0 Then
olAppItem.ReminderSet = True
olAppItem.ReminderMinutesBeforeStart = R.Cells(i, 7).Value
Else
olAppItem.ReminderSet = False
End If
olAppItem.Body = R.Cells(i, 8).Value
olAppItem.Display
Set olAppItem = Nothing
End If
Next
Set outNameSpace = Nothing
Set olAppItem = Nothing
End Sub

[/CODE]