Filtrage sur les rendez-vous du calendrier Outlook

Signaler
Messages postés
1
Date d'inscription
dimanche 22 décembre 2013
Statut
Membre
Dernière intervention
22 décembre 2013
-
Bonsoir,

Après plusieurs recherches sur le net, je me résouds à poser ma question.
Je travaille sous Outlook et j'ai créé une macro qui diffère l'envoi d'un mail à la prochaine date ne comportant pas d'événement sur la journée entière (CP, déplacement, etc...)
Mon traitement principal est deferMailDelivery() qui est appelé directement depuis un bouton sur la fenêtre de composition du mail. EIl fait appel la fonction isDayContainAllDayEvent() qui, à partir d'une date, détermine si cette journée est libre. C'est à mon avis sur cette fonction qu'il faut travailler; l'autre étant là pour illustration de son usage.

Mes soucis sont les suivants :
- Quelque soit la date que j'examine, j'ai toujours un rendez-vous au 30/07/2012 qui revient. Bien sûr, j'ai examiné mon calendrier, il n'y a rien à cette date.
- Ensuite, j'ai un soucis sur la condition de restriction. Visiblement, de ce que j'ai vu sur le net, je ne serais pas le seul... Pour une journée donnée, je dois examiner tous les rendez-vous marqués comme étant sur la journée entière en question (donc d'une durée de 1 jour). Mais également, je dois examiner les rendez-vous qui durent plusieurs journées entières et qui contiennent la journée en question.
J'ai beau tourner la clause de recherche dans tous les sens, quelque chose doit m'échapper ou bien la syntaxe n'est pas celle que je crois.

Exemple :
Sur une semaine, j'ai une absence du mercredi au jeudi inclus (2 jours pleins)
Si le mardi j'écris un mail que je souhaite différer, il devra partir le vendredi matin (premier jour disponible à partir du lendemain de l'écriture de mon mail).
Si le mercredi, j'écris un mail, il devra partir le vendredi également (premier jour disponible à partir du lendemain de l'écriture de mon mail).


Merci d'avance de votre assistance,


Public Sub deferMailDelivery()
Dim App As Outlook.Application
Dim DossierID
Dim Msg As Outlook.MailItem
Dim jourSemaine As Long
Dim dateEnvoi As Date
heureEnvoi = "07:00" 'Heure par défaut de l'envoi
offSetJourEnvoi = 1 'Nombre jour minimum par défait à partir duquel on cherche une disponibilité
limiteRecherche = 30 'Limite de sécurité pour éviter de boucler indéfiniment


Set Msg = Application.ActiveInspector.currentItem
If (Msg.DeferredDeliveryTime <> #1/1/4501#) Then
Msg.DeferredDeliveryTime = #1/1/4501#
MsgBox "** L'envoi différé a été ANNULE **"
Exit Sub
End If

timeEnvoi = TimeValue(heureEnvoi)
dateEnvoi = Date
dontPanicLoop = 0
Do
dontPanicLoop = dontPanicLoop + 1
dateEnvoi = dateEnvoi + offSetJourEnvoi
jourSemaine = Weekday(dateEnvoi, vbMonday)
If jourSemaine >= 6 Then
dateEnvoi = dateEnvoi + (8 - jourSemaine)
End If
If (dontPanicLoop > 30) Then
MsgBox "Hum, il y a un problème : aucun jour libre."
Exit Sub
End If

Loop While (isDayContainAllDayEvent(dateEnvoi))


dateEnvoi = dateEnvoi + timeEnvoi
Msg.DeferredDeliveryTime = dateEnvoi
MsgBox "Ce courrier sera envoyé le " & vbCrLf & vbCrLf & WeekdayName(Weekday(dateEnvoi, vbMonday)) & " " & dateEnvoi & vbCrLf
End Sub


Private Function isDayContainAllDayEvent(day As Date) As Boolean

Dim Session As Outlook.nameSpace
Dim Report As String
Dim AppointmentsFolder As Outlook.Folder
Dim currentItem As Object
Dim currentAppointment As AppointmentItem
Set Session = Application.Session
'MsgBox "Verif du " & day
Set AppointmentsFolder = Session.GetDefaultFolder(olFolderCalendar)
Set calendarItems = AppointmentsFolder.Items
calendarItems.Sort "[Start]"
'strFilter = "[Start] >='" & Format(day, "dd/mm/yyyy ") & " 00:00'AND [End] <= '" & Format(day + 1, "dd/mm/yyyy") & " 23:59'"
strFilter = "[Start] <= '" & Format(day, "m/d/yyyy ") & "' AND '" & Format(day, "m/d/yyyy") & "' <= [End]"
Set olFilterRecItems = AppointmentsFolder.Items.Restrict(strFilter)
olFilterRecItems.IncludeRecurrences = True
olFilterRecItems.Sort "[Start]"

isDayContainAllDayEvent = False


For Each currentItem In olFilterRecItems
'MsgBox "on regarde le " & currentItem.Start
If (currentItem.Class = olAppointment) Then
If (Format(currentItem.Start, "yyyymmdd") >= Format(day, "yyyymmdd")) Then

If (currentItem.AllDayEvent) Then
MsgBox "RDV journée le " & currentItem.Start
isDayContainAllDayEvent = True
Exit For
End If

End If
If (Format(currentItem.Start, "yyyymmdd") >= Format(day + 1, "yyyymmdd")) Then
Exit For
End If
End If
Next

End Function