1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55
| Sub FindAppts()
Dim myStart As Date
Dim myEnd As Date
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
Dim OL As Object
If UCase(Application) = "OUTLOOK" Then
Set OL = Application
Else
Set OL = CreateObject("outlook.application")
End If
myStart = Format(Date, "dd/mm/yyyy")
myEnd = DateAdd("d", 30, myStart)
Debug.Print "Start:", myStart
Debug.Print "End:", myEnd
'Construct filter for the next 30-day date range
strRestriction = "[Start] >= '" & myStart & "' AND [End] <= '" & myEnd & "'"
'Check the restriction string
Debug.Print strRestriction
Set oCalendar = OL.Session.GetDefaultFolder(olFolderCalendar)
Set oItems = oCalendar.Items
oItems.IncludeRecurrences = False
oItems.Sort "[Start]"
'Restrict the Items collection for the 30-day date range
Set oItemsInDateRange = oItems.Restrict(strRestriction)
'Construct filter for Subject containing 'team'
Const PropTag As String = "http://schemas.microsoft.com/mapi/proptag/"
' 0x8021101E
' les 3 écritures ci-dessous fonctionnent
'strRestriction = "[Catégories] = 'Congé (Jour de)'" ' nom exact de la catégorie
'strRestriction = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/Keywords" & Chr(34) & " like 'Congé (Jour de)'"
strRestriction = "@SQL=" & Chr(34) & "http://schemas.microsoft.com/mapi/string/{00020329-0000-0000-C000-000000000046}/Keywords" & Chr(34) & " like '%Congé%'"
'Restrict the last set of filtered items for the subject
Debug.Print strRestriction
Set oFinalItems = oItemsInDateRange.Restrict(strRestriction)
'Sort and Debug.Print final results
oFinalItems.Sort "[Start]"
MsgBox oFinalItems.Count
For Each oAppt In oFinalItems
Debug.Print oAppt.Start, oAppt.Subject
Next
End Sub |
Partager