CODEWITHSUNDEEP
excelvbaoutlookcalendar
sharsart
sharsart

Reputation: 228

Send appointments to shared calendar

I have a script which gets lab outage data from a SharePoint site. Depending certain conditions and if an outage is to occur it sends an appointment to Outlook.

Private Sub CreateAppt(Subject As String, startTime As Date, endTime As Date, _
  startDate As Date, endDate As Date, superString As String, _
  OUTAGEREQUIRED As String)
Dim body As String:
Dim myoutlook As Outlook.Application
Dim myRecipient As Outlook.Recipient
Dim myNameSpace As Outlook.Namespace
Dim olkCalendar As Object
Dim olkSession As Object
Dim myapt As Object ' Outlook.AppointmentItem
'Dim r As Long

' late bound constants
Const olAppointmentItem = 1
'Const olBusy = 2
Const olMeeting = 1

    ' Create the Outlook session
    'On Error GoTo meetingFailed
    Set myoutlook = Outlook.Application 'CreateObject("Outlook.Application")
    Set olkSession = myoutlook.Session
    Set myNameSpace = myoutlook.GetNamespace("MAPI")
    Set myRecipient = myNameSpace.CreateRecipient("***@.com")
    'Create the AppointmentItem
    'On Error GoTo meetingFailed
    Set myapt = myoutlook.CreateItem(olAppointmentItem)
    olkSession.Logon
    Set olkCalendar = olkSession.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
    ' Set the appointment properties
    With myapt
        .Subject = Subject
        .body = superString
        .Start = startDate & " " & startTime
        .End = endDate & " " & endTime
        .MeetingStatus = olMeeting
        .ReminderSet = True
        .ReminderMinutesBeforeStart = "5"
        'Conditional check -> if outageRequired is true then
        ' set BusyStatus to Busy and Color to red
        If (OUTAGEREQUIRED = True) Then
        .BusyStatus = 2
        .Categories = "Red Category"
        'Conditional check -> if OutageRequired is false then
        ' set BusyStatus to Free and Color to Blue
        ElseIf (OUTAGEREQUIRED = False) Then
        .BusyStatus = 0
        .Categories = "Blue Category"
        End If
        'Send emails to hardcoded email addresses
        'Primary email address is ******@***.com
        If Not DEBUGCODE Then
            .Recipients.Add "****@.com"
        Else
            .Recipients.Add "***@.com"
        End If
            .Recipients.ResolveAll
        .Save
        .Send
    End With
Exit Sub

It's sending the lab outage details to my personal Outlook calendar.

Is there a way to send the details to the shared calendar?

Upvotes: 1

Views: 834

Answers (1)

niton
niton

Reputation: 9179

Add to non-default folders.

Set olkCalendar = olkSession.GetSharedDefaultFolder(myRecipient, olFolderCalendar)
Set myapt = olkCalendar.Items.Add
With myapt
    …
    .Save
    ' Send
End With

Upvotes: 1

Related Questions