Sub FindAppts2() Dim myStart As Date Dim myEnd As Date Dim ons As outlook.NameSpace Dim oFldrBase As outlook.Folder Dim oCalendar As outlook.Folder Dim oItems As outlook.Items Dim oItemsInDateRange As outlook.Items Dim oFinalItems As outlook.Items Dim oAppt As outlook.AppointmentItem Dim strRestriction As String Set ons = outlook.GetNamespace("MAPI") ' pick up the relevant email folder from the database Control table - works fine Set oFldrBase = ons.Folders(Access.DFirst("DoSEmailFolder", "Control")) ' get reference to the calendar Set oCalendar = oFldrBase.Folders("Calendar") If adhIsOpen("DoSMain", acForm) Then With Forms("DoSMain") ' write in the txtUpcoming text box on the Access DoSMain form. .txtUpcoming = "" myStart = Date myEnd = DateAdd("d", 7, myStart) .txtUpcoming = .txtUpcoming & "Start:" & vbTab & myStart & vbCrLf .txtUpcoming = .txtUpcoming & "End:" & vbTab & myEnd & vbCrLf 'Construct filter for the next 7-day date range 'cribbed from internet example, but looks plausible '(I am still getting to know the Outlook way of doing things). strRestriction = "[Start] >= '" & _ Format$(myStart, "yyyy/mm/dd hh:mm AMPM") _ & "' AND [End] <= '" & _ Format$(myEnd, "yyyy/mm/dd hh:mm AMPM") & "'" 'Write the restriction string out to the text box, just so we can see it .txtUpcoming = .txtUpcoming & strRestriction & vbCrLf Set oItems = oCalendar.Items oItems.IncludeRecurrences = True oItems.Sort "[Start]" 'Get new supposedly smaller collection by doing a Restrict the Items collection 'for the 7-day date range Set oItemsInDateRange = oItems.Restrict(strRestriction) oItemsInDateRange.Sort "[Start]" 'Construct filter for Subject containing 'team'. THIS SEEMS TO WORK. Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/" strRestriction = "@SQL=" & Chr(34) & PropTag _ & "0x0037001E" & Chr(34) & " like '%team%'" 'Write the restriction string out to the text box, just so we can see it .txtUpcoming = .txtUpcoming & strRestriction & vbCrLf 'Restrict the last set of filtered items for the subject Set oFinalItems = oItemsInDateRange.Restrict(strRestriction) 'Sort and Debug.Print final results For Each oAppt In oFinalItems ' has appointments going back to 2011!! .txtUpcoming = .txtUpcoming & oAppt.Start & " " & oAppt.Subject & vbCrLf Next End With End If End Sub
From novice to tech pro — start learning today.