Once again, here is a simple procedure (based on a database I created many a moons ago) to extract a listing of appointments from your Outlook Calendar that I created to help someone in a forum. I thought the code could help others.
'---------------------------------------------------------------------------------------
' Procedure : GetFutureOutlookEvents
' Author : Daniel Pineault, CARDA Consultants Inc.
' Website : http://www.cardaconsultants.com
' Purpose : Generate a listing of future appointments from your Outlook Calendar
' Copyright : The following may be altered and reused as you wish so long as the
' copyright notice is left unchanged (including Author, Website and
' Copyright). It may not be sold/resold or reposted on other sites (links
' back to this site are allowed).
' Req'd Refs: None
'
' Usage:
' ~~~~~~
' Call GetFutureOutlookEvents
'
' Revision History:
' Rev Date(yyyy/mm/dd) Description
' **************************************************************************************
' 1 2016-09-08 Initial Release
'---------------------------------------------------------------------------------------
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
The above procedure uses a Items.Restrict Method to only list future appointments based on the current date. I did this just to demonstrate the ease with which you could extract specific details depending on your needs. Obviously, this can be modified, or eliminated depending on your needs.
This procedure also use Late Binding technics so no reference libraries are required, it is a simple plug & play procedure. Furthermore, it is not Access specific. This procedure could be run from Access, Word, Excel, or any other VBA platform.
Daniel: Great code! Have you ever had to do something similar with MS Project? Extract dates and pull into Access?
No, I haven’t really played with Project since my University days. None of my previous employers or clients have ever used it so I just haven’t has any need to do so.
Hey Daniel
I have used your code and have a little problem. I don’t get recurrence appointments in the same search? Otherwise it works all right.
Hi Daniel,
How would you set the sFilter so that all schedules between date x and date y is captured?
Thank you.