Discussion :

[omarter]

Bonjour,

J'utilise une macro depuis 6 mois qui me permet d'extraire les rdv de mon calendrier outlook dans une feuille excel. Elle fonctionnait très bien.
Depuis quelques jours elle ne fait plus la mise à jours des informations.

Visiblement elle passe un peu de temps sur la variable olApt, et n'entre pas dans la boucle "For Each olApt In ItemstoCheck" sans faire de message d'erreur.

Auriez vous une idée de quoi cela pourrait venir ?

Merci pour votre aide.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
Sub ListAppointments()
 
    Application.ScreenUpdating = False
 
    Dim olApp As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olApt As Object
    Dim NextRow As Long
    Dim myCalItems As Object
    Dim StringToCheck As String
'    Dim progression, compteur As String
    Dim ItemstoCheck As Object
'    Dim Image_barre, Label_barre As Object
 
 
'    UserForm_demo.Show
    Set olApp = CreateObject("Outlook.Application")
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
 
    Sheets("Extract Outlook").Select
'    Cells.Select
'    Selection.ClearContents
 
    Range("A1:G1").Value = Array("Catégories", "Sujet", "Start", "End", "Duration [h]", "Organizer", "Status")
 
    NextRow = 2
 
    ' Permet de capter les reccurences
    Set myCalItems = olFolder.Items '9=olFolderCalendar
 
    With myCalItems
        .Sort "[Start]", False
        .IncludeRecurrences = True
    End With
 
    ' Permet de définir la plage de recherche pour l'importation - Importation depuis le 01/03/2014
    StringToCheck = "[Start] >= " & Chr(34) & "01/03/2014" & " 12:00 AM" & Chr(34) & " AND [End] <= " & _
                    Chr(34) & Date & " 11:59 PM" & Chr(34)
    Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
 
    For Each olApt In ItemstoCheck
 
        Cells(NextRow, "A").Value = olApt.Categories
        Cells(NextRow, "B").Value = olApt.Subject
        Cells(NextRow, "C").Value = olApt.Start
        Cells(NextRow, "D").Value = olApt.End
        Cells(NextRow, "E").Value = olApt.Duration / 60
        'Cells(NextRow, "D").Value = olApt.Location
        Cells(NextRow, "F").Value = olApt.Organizer
        'Cells(NextRow, "I").Value = olApt.RequiredAttendees
        'Cells(NextRow, "G").Value = olApt.OptionalAttendees
        If olApt.BusyStatus = 0 Then Cells(NextRow, "G").Value = "Available"
        If olApt.BusyStatus = 2 Then Cells(NextRow, "G").Value = "Busy"
        If olApt.BusyStatus = 3 Then Cells(NextRow, "G").Value = "Out Office"
        'If olApt.Start < Date Then
            'Cells(NextRow, "H").Value = "No"
        'Else
            'Cells(NextRow, "H").Value = "Yes"
        'End If
 
        NextRow = NextRow + 1
 
        'In Progress Bar
'        UserForm_demo.Height = 121.5
'        progression = 0
'        compteur = compteur + 1
'
'        If compteur Mod 2500 = 0 Then '=> sera exécuté 100x
'            progression = progression + 1
'            Image_barre.Width = progression * 1.5
'            Label_barre.Caption = progression & "%"
'            DoEvents
'        End If
 
    Next olApt
 
    Set olApt = Nothing
    Set olFolder = Nothing
    Set olNS = Nothing
    Set olApp = Nothing
    Set myCalItems = Nothing
    Set ItemstoCheck = Nothing
 
    Columns.AutoFit
 
    ActiveWorkbook.Worksheets("Extract Outlook").ListObjects("Tableau24").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Extract Outlook").ListObjects("Tableau24").Sort. _
        SortFields.Add Key:=Range("C2"), SortOn:=xlSortOnValues, Order:= _
        xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Extract Outlook").ListObjects("Tableau24").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("Repartition").PivotTables("Tableau croisé dynamique3").PivotCache.Refresh
    Range("J6") = Now
    Sheets("Time Management To-Do").Select
    MsgBox ("Extraction Terminée")
 
        Application.ScreenUpdating = True
'    UserForm_demo.Height = 136.5
 
End Sub

[Marc-L]

Bonjour,

p'être bien commencer par vérifier le contenu de ItemstoCheck dans la fenêtre des Variables locales, non ?

[omarter]

Bonjour Marc-L

Merci pour ta réponse.
Existe une méthode pour trouver l'anomalie dans le contenu de ItemstoCheck via la fenêtre des Variables locales, car il y a une tonne d'information et j'ai de la peine a identifier la faille.

Merci pour ton support

[Marc-L]

En fait c'est visuel et devrait être évident lorsque l'on connait le sujet …

Si le code ne remplit plus son office, peut-être la source a-t-elle été modifiée, voie à explorer donc …

Sinon reste à effectuer une recherche dans la , les tutoriels et les discussions de ce forum
ou plus globalement sur le net (le site de Ron de Bruin par exemple, entre autres) …
Ou à espérer qu'un intervenant ait une solution …

__________________________________________________________________________________________________
Tous unis, tous Charlie