Click here to Skip to main content
Rate this: bad
good
Please Sign up or sign in to vote.
See more: VBScript
Hi..
 
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()
    GetListOfAppointmentsUsingPropertyAccessor
    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
    Next
    Call CreateReportAsEmail("List of Appointments", Report)
Exiting:
        Exit Sub
On_Error:
    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
 
*-----------------------
 
Thanks,
Thembani
Posted 6-Jun-11 0:43am
tembz427

1 solution

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

Solution 1

You have to use GetSharedDefaultFolder instead of GetDefaultFolder
First create a Recipient via .CreateRecipient
  Permalink  
Comments
tembz at 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

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

End

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")
myRecipient.Resolve
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)
CalendarFolder.Display
End Sub
Kim Togo at 6-Jun-11 6:15am
   
Skip the .Resolve and .Resolved.
In Outlook there is a security in place that prevents 3.party programs to access the Global Contact list.
tembz at 6-Jun-11 7:25am
   
How then do I loop through the list of calendars?
Kim Togo at 6-Jun-11 7:36am
   
You have to know all the calenders you want to access.
See this link: http://www.outlookcode.com/article.aspx?id=52

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



Advertise | Privacy | Mobile
Web04 | 2.8.1411022.1 | Last Updated 6 Jun 2011
Copyright © CodeProject, 1999-2014
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