Your question, your audience. Choose who sees your identity—and your question—with question security.
Public Sub CalendarView()
'This module attempts to produce an extract of dates (a date range)
'from the current outlook Calendar which is open, with the dates
'enered by the operator as a start date and an end date.
'Its aim is to produce a display of these calendar items in a view
'(although this final stepo is still pending).
'define variables and objects
Dim myNameSpace As Outlook.NameSpace
Dim oCalendar As Outlook.Folder
Dim oView As Outlook.View
Dim oItems As Outlook.Items
Dim strStart As String
Dim strEnd As String
Dim dStart As Date
Dim dEnd As Date
Dim strFilter As String
Dim objItem As Object
Dim oItemsInDateRange As Outlook.Items
'initialise various objects
Set myNameSpace = Application.GetNamespace("MAPI")
Set oCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
Set oView = oCalendar.CurrentView
Set oItems = oCalendar.Items
'make sure the operator has a calendar view open
If oView.ViewType = olCalendarView Then
'there is error checking on the dates.
'Note: You may need to tweak the code to agree with your localdate format
' e.g. Uk/Australia = "dd/mm/yyyy" whereas USA is "mm/dd/yyyy"
'pick up the values used last time macro was run
strStart = Format(GetSetting(Application.Name, "Setup", "CalendarViewStart", Now()), "dd/mm/yyyy")
strEnd = Format(GetSetting(Application.Name, "Setup", "CalendarViewEnd", Now() + 31), "dd/mm/yyyy")
On Error GoTo InputStart
strStart = InputBox("Start date? (mm/dd/yyyy)", "Setup Calendar View", strStart)
If Not IsDate(strStart) Then GoTo InputEnd
dStart = CDate(strStart)
On Error GoTo InputEnd
strEnd = InputBox("End date? (mm/dd/yyyy)", "Setup Calendar View", strEnd)
If Not IsDate(strEnd) Then GoTo InputEnd
dEnd = CDate(strEnd)
On Error GoTo 0
If dEnd < dStart Then
MsgBox "End date must follow start date"
'save the current values for next run
SaveSetting Application.Name, "Setup", "CalendarViewStart", dStart
SaveSetting Application.Name, "Setup", "CalendarViewEnd", dEnd
'Now the fun begins!
'these items must be performed n this order and results in a collection of
'calendar items that meet the date restrictions (sorted into dare order, oldest to latest)
oItems.IncludeRecurrences = True 'we need to incororate recurring items otherwise something
'sheculed for "Wednesday each week" would only show once!
strFilter = "[Start] >= '" & _
Format(dStart, "ddddd") & " 12:00 AM'" & _
" AND [End] <= '" & _
Format(dEnd, "ddddd") & " 11:59 PM'"
'You must "find" the first item for the filter to "kick-in"
Set objItem = oItems.Find(strFilter)
'now we use "restrict" rather than "filter" since "restirct" is much faster!
Set oItemsInDateRange = oItems.Restrict(strFilter)
'Now we sort the items
oItemsInDateRange.Sort "[Start]", False
'we could list these items to the debug screen if we want (useless but proves we obtained the items)
'instead we will just produce a little message saying how many items are in the collection just to
'prove things work.
MsgBox "Calendar Items found: " + CStr(oItemsInDateRange.Count)
MsgBox "Please make sure a calendar view is currently displaying"
Open in new window
Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.
Have a better answer? Share it in a comment.
Please enter a first name
Please enter a last name
Must be at least 4 characters long.
Join and Comment
Be seen. Boost your question’s priority for more expert views and faster solutions