Recherche evenement periodique dans outlook

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

Rechercher des sujets similaires à "recherche evenement periodique outlook"