Identify a public calendar in a macro

Degards

New Member
Joined
Feb 2, 2022
Messages
2
Office Version
  1. 2013
Platform
  1. Windows
Hello to you, using a macro I would like to retrieve the appointments of a public calendar of my organization. I am able to retrieve the appointments in my default calendar but I can't find how to access this public calendar. I even know its ID 000000001A447390AA6611CD9BC800AA002FC45A0380C7933BA462E7E843A8141C81876EF43900009EDB71580000.

Can someone help me on the access procedure.

There is the code i had found

Thanks
Degards
VBA Code:
Sub GetFutureOutlookEvents()
    Dim oOutlook              As Object
    Dim oNS                   As Object
    Dim oAppointments         As Object
    Dim oFilterAppointments   As Object
    Dim oAppointmentItem      As Object
    Dim bOutlookOpened        As Boolean
    Dim i                     As Long
    Const olFolderCalendar = 9
 
    On Error Resume Next
    Set oOutlook = GetObject(, "Outlook.Application")    'Bind to existing instance of Outlook
    If Err.Number <> 0 Then    'Could not get instance of Outlook, so create a new one
        Err.Clear
        Set oOutlook = CreateObject("Outlook.Application")
        bOutlookOpened = False    'Outlook was not already running, we had to start it
    Else
        bOutlookOpened = True    'Outlook was already running
    End If
    On Error GoTo Error_Handler
    DoEvents
 
    Set oNS = oOutlook.GetNamespace("MAPI")
    Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
    'Apply a filter so we don't waste our time going through old stuff if we don't need to.
    sFilter = "[Start] > '" & Date & "'"
    Set oFilterAppointments = oAppointments.Items.Restrict(sFilter)
    Debug.Print oFilterAppointments.Count & " appointments found."
    'Iterate through each appt in our calendar
    For Each oAppointmentItem In oFilterAppointments
        Debug.Print oAppointmentItem.Subject, oAppointmentItem.Start, oAppointmentItem.End
    Next
 
    If bOutlookOpened = False Then    'Since we started Outlook, we should close it now that we're done
        oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
    End If
 
Error_Handler_Exit:
    On Error Resume Next
    Set oAppointmentItem = Nothing
    Set oFilterAppointments = Nothing
    Set oAppointments = Nothing
    Set oNS = Nothing
    Set oOutlook = Nothing
    Exit Sub
 
Error_Handler:
    MsgBox "The following error has occurred" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetFutureOutlookEvents" & vbCrLf & _
           "Error Description: " & Err.Description _
           , vbOKOnly + vbCritical, "An Error has Occurred!"
    Resume Error_Handler_Exit
End Sub
 

Excel Facts

Waterfall charts in Excel?
Office 365 customers have access to Waterfall charts since late 2016. They were added to Excel 2019.
I can't test now because I am no longer at the company where I had access to a public calendar, but when I was, I used the following code, which slowly got to the public calendar by finding subfolder names. Note that this was in Outlook, so I don't use "As Object" designators.
VBA Code:
    Dim myOlApp As Application
    Dim objNS As NameSpace, fldr As MAPIFolder
    
    Set myOlApp = CreateObject("Outlook.Application")
    Set objNS = myOlApp.GetNamespace("MAPI")
    Set fldr = objNS.Folders("Public Folders")
    Set fldr = fldr.Folders("All Public Folders")
    Set fldr = fldr.Folders("Office Calendar")
However, since you know the EntryID, you might get away with setting fldr directly:
VBA Code:
Set fldr = objNS.GetFolderFromID("000000001A447390AA6611CD9BC800AA002FC45A0380C7933BA462E7E843A8141C81876EF43900009EDB71580000")
In your case, my "fldr" would be your "oAppointments".
 
Upvote 0
I can't test now because I am no longer at the company where I had access to a public calendar, but when I was, I used the following code, which slowly got to the public calendar by finding subfolder names. Note that this was in Outlook, so I don't use "As Object" designators.
VBA Code:
    Dim myOlApp As Application
    Dim objNS As NameSpace, fldr As MAPIFolder
   
    Set myOlApp = CreateObject("Outlook.Application")
    Set objNS = myOlApp.GetNamespace("MAPI")
    Set fldr = objNS.Folders("Public Folders")
    Set fldr = fldr.Folders("All Public Folders")
    Set fldr = fldr.Folders("Office Calendar")
However, since you know the EntryID, you might get away with setting fldr directly:
VBA Code:
Set fldr = objNS.GetFolderFromID("000000001A447390AA6611CD9BC800AA002FC45A0380C7933BA462E7E843A8141C81876EF43900009EDB71580000")
In your case, my "fldr" would be your "oAppointments".
I try your solution and they works !!

Thank you
 
Upvote 0

Forum statistics

Threads
1,196,429
Messages
6,015,198
Members
441,882
Latest member
rcgyuk

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top