Click here to Skip to main content
13,087,941 members (62,936 online)
Rate this:
Please Sign up or sign in to vote.
See more:

I am a newbie in development. At work I have a personal calendar and then there are shared calendars that I have access to. I am trying to write a script that retrieves the appointments in each of these shared calendars, but the code I currently use (adapted from Greg Thatcher) only allows me to retrieve appointments in MY calendar. Any assistance is appreciated. below is the code I have.


Option Explicit
Private Sub CommandButton1_Click()
    Exit Sub
End Sub
Public Sub GetListOfAppointmentsUsingPropertyAccessor()
    On Error GoTo On_Error
    Dim Session As Outlook.NameSpace
    Dim Report As String
    Dim szNewDate As String
    Dim AppointmentsFolder As Outlook.Folder
    Dim currentItem As Object
    Dim currentAppointment As AppointmentItem
    Set Session = Application.Session
    Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)
    For Each currentItem In AppointmentsFolder.Items
        If (currentItem.Class = olAppointment) Then
            Set currentAppointment = currentItem
            Call AddToReportIfNotBlank(Report, "BEGIN", "VCALENDAR")
            Call AddToReportIfNotBlank(Report, "BEGIN", "VEVENT")
            Call AddToReportIfNotBlank(Report, "ATTENDEE;CN=", currentAppointment.RequiredAttendees)
            Call AddToReportIfNotBlank(Report, "CLASS", "PRIVATE")
            Call AddToReportIfNotBlank(Report, "CREATED", DateConv(currentAppointment.CreationTime))  '- '18/02/2011 11:48:02
            Call AddToReportIfNotBlank(Report, "DTEND", DateConv(currentAppointment.EndInEndTimeZone)) '- '0110530T080000Z
            Call AddToReportIfNotBlank(Report, "DTSTART", DateConv(currentAppointment.Start)) '- '20110530T070000Z
            Call AddToReportIfNotBlank(Report, "LAST-MODIFIED", DateConv(currentAppointment.LastModificationTime)) '- '20110530T071826Z
            Call AddToReportIfNotBlank(Report, "LOCATION", currentAppointment.Location)
            Call AddToReportIfNotBlank(Report, "ORGANIZER;CN=", currentAppointment.Organizer)
            Call AddToReportIfNotBlank(Report, "SUMMARY;LANGUAGE=en-us", currentAppointment.ConversationTopic)
            Call AddToReportIfNotBlank(Report, "UID", currentAppointment.EntryID)
            Call AddToReportIfNotBlank(Report, "END", "VEVENT")
            Call AddToReportIfNotBlank(Report, "END", "VCALENDAR")
            Report = Report & "--------------------------------------------------------------------------------------------------------"
            Report = Report & vbCrLf & vbCrLf
        End If
    Call CreateReportAsEmail("List of Appointments", Report)
        Exit Sub
    MsgBox "error=" & Err.Number & " " & Err.Description
    Resume Exiting
End Sub
Private Function AddToReportIfNotBlank(Report As String, FieldName As String, FieldValue)
    AddToReportIfNotBlank = ""
    If (IsNull(FieldValue) Or FieldValue <> "") Then
        AddToReportIfNotBlank = Trim(FieldName & ":" & FieldValue & vbCrLf)
        Report = Report & AddToReportIfNotBlank
    End If
End Function


Posted 5-Jun-11 23:43pm

1 solution

Rate this: bad
Please Sign up or sign in to vote.

Solution 1

You have to use GetSharedDefaultFolder instead of GetDefaultFolder
First create a Recipient via .CreateRecipient
tembz 6-Jun-11 6:06am
Thanks Kim. Below is sample code I found from the "help" in Outlook of how to create a Receipient. I ran this and it gives me an error that "A dialog box is open." Find the code attached:

Private Sub CommandButton1_Click()
On Error GoTo On_Error

Call ResolveName

Exit Sub
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting


End Sub

Sub ResolveName()
Dim myNamespace As Outlook.NameSpace
Dim myRecipient As Outlook.Recipient
Dim CalendarFolder As Outlook.Folder

Set myNamespace = Application.GetNamespace("MAPI")
Set myRecipient = myNamespace.CreateRecipient("Thembani Nxumalo")
If myRecipient.Resolved Then
Call ShowCalendar(myNamespace, myRecipient)
End If
End Sub

Sub ShowCalendar(myNamespace, myRecipient)
Dim CalendarFolder As Outlook.Folder
Set CalendarFolder = myNamespace.GetSharedDefaultFolder _
(myRecipient, olFolderCalendar)
End Sub
Kim Togo 6-Jun-11 6:15am
Skip the .Resolve and .Resolved.
In Outlook there is a security in place that prevents programs to access the Global Contact list.
tembz 6-Jun-11 7:25am
How then do I loop through the list of calendars?
Kim Togo 6-Jun-11 7:36am
You have to know all the calenders you want to access.
See this link:

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

  Print Answers RSS
Top Experts
Last 24hrsThis month

Advertise | Privacy |
Web03 | 2.8.170813.1 | Last Updated 6 Jun 2011
Copyright © CodeProject, 1999-2017
All Rights Reserved. Terms of Service
Layout: fixed | fluid

CodeProject, 503-250 Ferrand Drive Toronto Ontario, M3C 3G8 Canada +1 416-849-8900 x 100