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
| Sub Test_GetTable_appointments()
Dim oFolder As Outlook.Folder
Dim criteria
Dim oTable As Table
Dim i, oRow, R, arr
Set oFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
criteria = "[MessageClass] = 'IPM.Appointment'"
Dim DateToCheck As Date
DateToCheck = Date
'On cherche entre la date -1mois et demain
FILTRE = " and [Start] >= '" & Format(DateAdd("M", -1, DateToCheck), "ddddd") & " 0:00 AM' "
FILTRE = FILTRE & " and [Start] <= '" & Format(DateAdd("d", 1, DateToCheck), "ddddd") & " 0:00 AM' "
Set oTable = oFolder.GetTable(criteria & FILTRE, olUserItems)
With oTable.Columns
'par defaut
'1 EntryID
'2 Subject
'3 CreationTime
'4 LastModificationTime
'5 MessageClass
'6 Start
'7 End
'8 IsRecurring
.add ("Location")
.add ("Categories")
.add ("BillingInformation")
.add ("ReminderSet")
.add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F") 'body
End With
oTable.sort "Start", True
MsgBox oTable.GetRowCount, , "Nombre de rdv trouvés (filtre)"
Do Until (oTable.EndOfTable)
Set oRow = oTable.GetNextRow()
If Year(oRow("Start")) <= 2018 Then
MsgBox oRow("Subject") & vbCr & _
oRow("Start") & vbTab & "-->" & oRow("End") & vbCr & _
"Categories =" & oRow("Categories") & vbCr & _
"BillingInformation=" & oRow("BillingInformation") & vbCr & _
"ReminderSet=" & oRow("ReminderSet") & vbCr & _
"Body=" & oRow("http://schemas.microsoft.com/mapi/proptag/0x1000001F")
End If
Loop
End Sub |
Partager