Filter Outlook appointments

Question

I have a Calendar in a Public Folder There are approximately 15000 appointments in the calendar over a period of several years I have used OutlookSpy to get the EntryId for the Calendar Using an example from an Outlook Programming book

Private Sub GetAppointmentsForDate(dteDate As Date)

Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colCal As Outlook.Items
Dim strFind As String
Dim colMyAppts As Outlook.Items
Dim objAppt As Outlook.AppointmentItem

Set objApp = CreateObject("Outlook.Application")
Set objNS = Application.GetNamespace("MAPI")

Set colCal = objNS.GetFolderFromID("{the Entry ID from OutlookSpy}").Items

colCal.Sort "[Start]"
colCal.IncludeRecurrences = True

Set colMyAppts = Nothing

strFind = "[Start] >= " & DoubleQuote(Format(dteDate, "dd mmm yyyy") & " 12:00 AM") & " AND [Start] < " & DoubleQuote(Format(dteDate + 1, "dd mmm yyyy") & " 12:00 AM")

Set colMyAppts = colCal.Restrict(strFind)
For Each objAppt In colMyAppts
Debug.Print objAppt.Start & vbTab & objAppt.Subject
Next
'clean up the objects used here
End Sub

I'd like to be able to do this using MAPI directly (CDO 1.21) The filtering sometimes takes up to 2 minutes, and I'd like to get this down to a few seconds.

If anyone has any idea's or improvements to the example code, I'd appreciate your input. [Any flavour of VB welcome]

Answer 1

There are a number of ways to do this. It depends on what and where you are doing this.

Looking at you code it looks like you are out of proc, but the options could be: hit the server via Dav or EWS, use Tables OOM or search folders (if you are using later version of outlook), use RDO or CDO as you say etc. Following your thoughts on CDO, the way to do it with speed would be to use MapiTables objects.

I would use RDO instead of CDO as it has a nice helper methods ok it has a small cost but is very useful http://www.dimastr.com/redemption/ (its by the same guy that made outlookspy.)

This code is written of the top of my head so may need some correcting but it will put you on the right track. If you give more details on versions and where you are running this maybe I could add more.

Marcus

    Dim objRDOSession As Redemption.RDOSession
    Dim objCalRDOFolder As Redemption.RDOFolder
    Dim objMapiTable As Redemption.MapiTable
    Dim objRecordset As Recordset
    Set objRDOSession = CreateObject("Redemption.RDOSession")
    objRDOSession.Logon
    Set objCalRDOFolder = objRDOSession.GetFolderFromPath("<folder path>")
    'Set oCalFolder = objRDOSession.GetFolderFromID("<entry id>")'
   Set objMapiTable = CreateObject("Redemption.MAPITable")
    objMapiTable.Item = objCalRDOFolder.Items
   Set objRecordset = objMapiTable.ExecSQL("SELECT Subject, Start from Folder where  Start >='2008-06-10'  and Start < '2009-06-10'")
        While Not objRecordset.EOF
            Debug.Print (objRecordset.Fields("Start").Value & ":" & objRecordset.Fields("Subject").Value)
        Recordset.MoveNext
    Wend
' clean up etc

update : try http://schemas.microsoft.com/mapi/proptag/0x001A001E istead of start