Temps d'exécution de macro élevée pour importer mon calendrier Outlook

Bonjour,

En cherchant sur le net, j'ai arrivé à créer un code dans Excel pour insérer mes rendez-vous de mon calendrier Outlook.

Il fonctionne, mais.. il y a toujours des mais. Si j'insère qu'une de ces deux lignes (n'importe laquelle) :

OokItem.IncludeRecurrences = True
OokItem.Sort "[Start]"

Cela fonctionne en 1 seconde, mais je n'ai que le premier de mes rendez-vous périodique (et j'ai beaucoup de visio périodique), je n'ai pas les suivants.

En insérant les deux lignes ci-dessus, tous mes rendez-vous apparaissent, mais la macro tourne pendant 2 minutes.

Si je la stop par un Ctrl + Pause au bout de 3 secondes, toutes mes données sont quand même là.

Je pense que dans ma boucle While, il me manque une fonction, mais je ne vois pas laquelle. Si quelqu'un aurait une petite idée...

Merci d'avance et attendant, bonne soirée

Dominique

Sub ImportOutlook()
Dim OlApp As Outlook.Application
Dim OokApp As New Outlook.Application
Dim OokMapi As Outlook.Namespace
Dim OokFold As Outlook.MAPIFolder
Dim OokItem As Outlook.Items
Dim OokApmt As Outlook.AppointmentItem
Dim oItemsInDateRange As Outlook.Items

Dim ListApre As Worksheet, CRM As Worksheet, Don As Worksheet, Agenda As Worksheet
Dim DatDeb As String
Dim DatFin As String
Dim I As Long, J As Long

Application.ScreenUpdating = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Set ListApre = Sheets("Liste_Apprenants")
Set CRM = Sheets("CRM_Extend")
Set Don = Sheets("Donnees")
Set Agenda = Sheets("Agenda")

Set OokMapi = OokApp.GetNamespace("MAPI")
Set OokFold = OokMapi.Folders("mon@adressemail").Folders("Calendrier")
Set OokItem = OokFold.Items

 'Date de début et de fin des événemets recherchées
If Don.Range("CE21").Value - 1 > Date Then
    DatDeb = Don.Range("CE21").Value - 1
Else
    DatDeb = Date
End If
DatFin = Don.Range("CE22").Value + 1

'Efface les anciennes données
Agenda.Range("A1:C500").ClearContents

'Insert les nouvelles données dans mon tableau
Set OokApmt = OokItem.Find("[Start] >= '" & DatDeb & "'")
OokItem.IncludeRecurrences = True
OokItem.Sort "[Start]"
I = 2

While TypeName(OokApmt) <> "Nothing"
          If OokApmt.Start > DatDeb And OokApmt.Start < DatFin Then
          I = I + 1
        Agenda.Range("A" & I) = DateValue(Format(OokApmt.Start, "dd/mm/yyyy"))
        Agenda.Range("B" & I) = Format(OokApmt.Start, "hh:mm")
        Agenda.Range("C" & I) = Format(OokApmt.End, "hh:mm")
    End If
    Set OokApmt = OokItem.FindNext

Wend

Application.ScreenUpdating = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

End Sub

Bonsoir,

Essayer ce code

Sub ImportOutlook()
    Dim OlApp As New Outlook.Application
    Dim calendrier As Outlook.Folder
    Dim evts_trouvés As Outlook.Items
    Dim evt As Outlook.AppointmentItem
    Dim filtre As String

    Dim ListApre As Worksheet, CRM As Worksheet, Don As Worksheet, Agenda As Worksheet
    Dim DatDeb As Date
    Dim DatFin As Date
    Dim I As Long, J As Long

    Application.ScreenUpdating = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual

    Set ListApre = Sheets("Liste_Apprenants")
    Set CRM = Sheets("CRM_Extend")
    Set Don = Sheets("Donnees")
    Set Agenda = Sheets("Agenda")
     'Date de début et de fin des événemets recherchées
    If Don.Range("CE21").Value - 1 > Date Then
        DatDeb = Don.Range("CE21").Value - 1
    Else
        DatDeb = Date
    End If
    DatFin = Don.Range("CE22").Value + 1

    'Efface les anciennes données
    Agenda.Range("A1:C500").ClearContents

    'affectation calendrier
    Set calendrier = OlApp.session.Folders("mon@adressemail").Folders("Calendrier")

    'filtrage des événements correspondant à la fourchette de dates
    filtre = "[Start] > '" & Format(DatDeb, "ddddd") & "'" & "And" & "[Start] < '" & Format(DatFin, "ddddd") & "'"
    Set evts_trouvés = calendrier.Items.Restrict(filtre)

    'analyse des événements trouvés
    I = 2
    For Each evt In evts_trouvés
        I = I + 1
        Agenda.Range("A" & I) = DateValue(Format(evt.Start, "dd/mm/yyyy"))
        Agenda.Range("B" & I) = Format(evt.Start, "hh:mm")
        Agenda.Range("C" & I) = Format(evt.End, "hh:mm")
    Next evt

    Application.ScreenUpdating = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Bonsoir Thev et merci

Le code que tu m'as fournit fonctionne mais n'insere pas les rdv périodique. Après la ligne

  Set evts_trouves = calendrier.Items.Restrict(filtre)

j'ai ajouté

    evts_trouves.IncludeRecurrences = True
    evts_trouves.Sort "[Start]"

et là, merveille, tout fonctionne et rapidement s'il vous plait.

Un grand merci pour cette réponse efficace et rapide.

Bonne nuit et encore grand merci

Dominique