Recherche evenement periodique dans outlook
s
Bonjour,
J'ai ce code qui me permet de récupérer les événements d'outlook commencant par *
Cela fonctionne
Sub testcaloutlook1()
Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
'
Dim datedebut As String
Dim datefin As String
Dim S As String
Dim comb As String
Dim sujet As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' informe de la date de début et de fin des événemets du calendrier à rechercher
datedebut = Date - 10
datefin = Date + 90
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
OutlItems.IncludeRecurrences = True
OutlItems.Sort "[Start]"
' efface les valeurs des cellules de la ligne 54 comprise entre la date de début et de la la date de fin de la ligne 55
Set plage2 = ThisWorkbook.Worksheets("Stats repas").Range("f55:oi55")
' recherche n° de colonnes de la feuille entre date de début et de fin
For Each Cell In plage2
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
If Cell.Value > CDate(datedebut) And Cell.Value < CDate(datefin) Then
' efface valeurs de la cellule
Cell.ClearComments
Cells(54, col).ClearContents
End If
Next Cell
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
' boucle sur calendrier outlook entre date debut et date fin
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Start > datedebut And OutlAppointment.Start < datefin Then
S = Left(OutlAppointment.Subject, 1)
' recherche événements du calendrier commencant par *
If S = "*" Then
ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
' recherche colonne de la date
For Each Cell In plage2
If Cell.Value = CDate(ddd1) Then
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
End If
Next Cell
sujet = OutlAppointment.Subject
' copie valeurs de l evenement du calendrier dans la cellule
If Cells(54, col1) = "" Then
Cells(54, col1) = OutlAppointment.Subject
Cells(54, col1).ShrinkToFit = True
Cells(52, col1) = OutlAppointment.Subject & " " & OutlAppointment.Location
Else
Cells(54, col1) = Cells(54, col1) & Chr(10) & OutlAppointment.Subject
Cells(52, col1) = Cells(52, col1) & Chr(10) & OutlAppointment.Subject & " " & OutlAppointment.Location
End If
End If
End If
Set OutlAppointment = OutlItems.FindNext
Wend
Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
mais sans prendre en compte les événement périodiques
J'ai rajouté après
Set OutlItems = OutlFolder.Items
OutlItems.IncludeRecurrences = True
OutlItems.Sort "[Start]"
si je rajoute que
OutlItems.IncludeRecurrences = True
ca ne fonctionne pas
et si je rajoute les 2 lignes :
OutlItems.IncludeRecurrences = True
OutlItems.Sort "[Start]"
excel rame, l'execution ne s'arrête pas mais quand je debbuge il a bien pris en compte les événements périodiques.
Pourriez vous m'aider svp pour que le calcul se fasse vite comme il le faavec le 1er code sans ces 2 lignes?
voici le code en entier
Sub testcaloutlook1()
Dim OutlApp As New Outlook.Application
Dim OutlMapi As Outlook.Namespace
Dim OutlFolder As Outlook.MAPIFolder
Dim OutlItems As Outlook.Items
Dim OutlAppointment As Outlook.AppointmentItem
'
Dim datedebut As String
Dim datefin As String
Dim S As String
Dim comb As String
Dim sujet As String
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.DisplayAlerts = False
' informe de la date de début et de fin des événemets du calendrier à rechercher
datedebut = Date - 10
datefin = Date + 90
'
Set OutlMapi = OutlApp.GetNamespace("MAPI")
Set OutlFolder = OutlMapi.GetDefaultFolder(olFolderCalendar)
Set OutlItems = OutlFolder.Items
OutlItems.IncludeRecurrences = True
OutlItems.Sort "[Start]"
' efface les valeurs des cellules de la ligne 54 comprise entre la date de début et de la la date de fin de la ligne 55
Set plage2 = ThisWorkbook.Worksheets("Stats repas").Range("f55:oi55")
' recherche n° de colonnes de la feuille entre date de début et de fin
For Each Cell In plage2
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
If Cell.Value > CDate(datedebut) And Cell.Value < CDate(datefin) Then
' efface valeurs de la cellule
Cell.ClearComments
Cells(54, col).ClearContents
End If
Next Cell
Set OutlAppointment = OutlItems.Find("[Start] >= '" & datedebut & "'")
' boucle sur calendrier outlook entre date debut et date fin
While TypeName(OutlAppointment) <> "Nothing"
If OutlAppointment.Start > datedebut And OutlAppointment.Start < datefin Then
S = Left(OutlAppointment.Subject, 1)
' recherche événements du calendrier commencant par *
If S = "*" Then
ddd1 = Format(OutlAppointment.Start, "dd/mm/yyyy")
' recherche colonne de la date
For Each Cell In plage2
If Cell.Value = CDate(ddd1) Then
col1 = Cell.Column
col = Mid(Cell.Address, 2, InStr(2, Cell.Address, "$") - 2)
End If
Next Cell
sujet = OutlAppointment.Subject
' copie valeurs de l evenement du calendrier dans la cellule
If Cells(54, col1) = "" Then
Cells(54, col1) = OutlAppointment.Subject
Cells(54, col1).ShrinkToFit = True
Cells(52, col1) = OutlAppointment.Subject & " " & OutlAppointment.Location
Else
Cells(54, col1) = Cells(54, col1) & Chr(10) & OutlAppointment.Subject
Cells(52, col1) = Cells(52, col1) & Chr(10) & OutlAppointment.Subject & " " & OutlAppointment.Location
End If
End If
End If
Set OutlAppointment = OutlItems.FindNext
Wend
Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Je vous remercie beaucoup de votre aide
Cordialement