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
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