Macro import calendrier outlook et calendriers partagés

**joponta** · 16/05/2023, 19h09

Bonsoir,

Dans la macro ci-dessous je récupère les informations de mon calendrier outlook.
Je souhaiterais récupérer tous les informations du dossier calendriers partagés ( calendrier de Paul, Pierre...)
Je ne parviens pas à trouver la solution après des recherches.
Quelqu’un a-t-il la solution ?

Merci.

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
Sub ListAppointments()
        Dim olApp As Object
        Dim olNS As Object
        Dim olFolder As Object
        Dim olApt As Object
        Dim NextRow As Long
        Dim FromDate As Date
        Dim ToDate As Date
 
        FromDate = Range("H1")
        ToDate = Range("I1")
 
 
        On Error Resume Next
        Set olApp = GetObject(, "Outlook.Application")
 
 
 
        If Err.Number > 0 Then Set olApp = CreateObject("Outlook.application")
 
        On Error GoTo 0
 
        Set olNS = olApp.GetNamespace("MAPI")
        Set olFolder = olNS.GetDefaultFolder(9) 'olFolderCalendar
 
        NextRow = 2
 
 
 
With Sheets("calend")  'Change the name of the sheet here
            .Range("A1:D1").Value = Array("Project", "Date", "Time spent", "Location")
            For Each olApt In olFolder.Items
            If olApt.Subject <> "REC" Then
                If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
                    .Cells(NextRow, "A").Value = olApt.Subject
                    .Cells(NextRow, "B").Value = CDate(olApt.Start)
                    .Cells(NextRow, "C").Value = olApt.End - olApt.Start
                    .Cells(NextRow, "C").NumberFormat = "HH:MM"
                    .Cells(NextRow, "D").Value = olApt.Location
                    .Cells(NextRow, "E").Value = olApt.Categories
                    .Cells(NextRow, "F").Value = olApt.RequiredAttendees
                    NextRow = NextRow + 1
 
 
                Else
                End If
                End If
            Next olApt
 
        End With
 
 
        Set olApt = Nothing
        Set olFolder = Nothing
        Set olNS = Nothing
        Set olApp = Nothing
    End Sub

**joponta** · 22/05/2023, 13h53

Bonjour,

J'ai essayé avec la macro ci-dessous, mais j'ai une erreur incompatibilité de type :

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
Sub ListAppointments()
 
Dim olApp As Object
Dim olNS As Object
Dim olFolder As Object
Dim olApt As Object
Dim objOwner As Object
Dim olFolderCalendar As Object
 
Dim NextRow As Long
 
Set olApp = CreateObject("Outlook.Application")
 
Set olNS = olApp.GetNamespace("MAPI")
 
Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
 
objOwner.Resolve
 
If objOwner.Resolved Then
 
    MsgBox objOwner.Name
    Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
 
End If
 
Range("A1:D1").Value = Array("Subject", "Start", "End", "Location")
 
NextRow = 2
 
For Each olApt In olFolder.Items
    Cells(NextRow, "A").Value = olApt.Subject
    Cells(NextRow, "B").Value = olApt.Start
    Cells(NextRow, "C").Value = olApt.End
    Cells(NextRow, "D").Value = olApt.Location
    NextRow = NextRow + 1
Next olApt
 
Set olApt = Nothing
Set olFolder = Nothing
Set olNS = Nothing
Set olApp = Nothing
 
Columns.AutoFit
 
End Sub

**joe.levrai** · 22/05/2023, 14h14

Bonjour,

quelle est la ligne marquée en erreur ?

A noter que tu travailles en late binding, ce qui signifie que tu ne peux pas utiliser la constante olFolderCalendar en toute sécurité dans ta procédure (il faut que la référence à Outlook soit cochée), il est préférable de la remplacer par son équivalent numérique qui est le 9 de mémoire

**joponta** · 22/05/2023, 15h21

je n'ai plus l'erreur à présent.
Par contre j'arrive à lire seulement mon calendrier.
Je ne peux pas lire le calendrier d'un collaborateur, bien que son calendrier soit partagé (paul.durand@dom.fr).

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
Option Explicit
 
Public Sub ListAppointments()
On Error GoTo ErrHand:
 
    Application.ScreenUpdating = False
 
    'This is an enumeration value in context of getDefaultSharedFolder
    Const olFolderCalendar As Byte = 9
 
    Dim olApp       As Object: Set olApp = CreateObject("Outlook.Application")
    Dim olNS        As Object: Set olNS = olApp.GetNamespace("MAPI")
    Dim olFolder    As Object
    Dim olApt       As Object
    Dim objOwner    As Object: Set objOwner = olNS.CreateRecipient("paul.durand@dom.fr")
    Dim NextRow     As Long
    Dim ws          As Worksheet: Set ws = ThisWorkbook.Sheets("calend")
    Dim FromDate As Date
    Dim ToDate As Date
    FromDate = InputBox("Enter the start date (format: dd/mm/yyyy)")
   ToDate = InputBox("Enter the end date(format: dd/mm/yyyy)")
 
    objOwner.Resolve
 
    If objOwner.Resolved Then
        Set olFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
    End If
 
    ws.Range("A1:D1").Value2 = Array("Subject", "Start", "End", "Location")
 
    'Ensure there at least 1 item to continue
    Debug.Print olFolder.Items.Count
    If olFolder.Items.Count = 0 Then Exit Sub
 
    'Create an array large enough to hold all records
    Dim myArr() As Variant: ReDim myArr(0 To 3, 0 To olFolder.Items.Count - 1)
 
    'Add the records to an array
    'Add this error skip, as I found some of my calendar items don't have all properties e.g. a start time
    On Error Resume Next
 
    For Each olApt In olFolder.Items
    If (olApt.Start >= FromDate And olApt.Start <= ToDate) Then
        myArr(0, NextRow) = olApt.Subject
        myArr(1, NextRow) = olApt.Start
        myArr(2, NextRow) = olApt.End
        myArr(3, NextRow) = olApt.Location
        NextRow = NextRow + 1
        Else
        End If
    Next
    On Error GoTo 0
 
    'Write all records to a worksheet from an array, this is much faster
    ws.Range("A2:D" & NextRow + 1).Value = WorksheetFunction.Transpose(myArr)
 
    'AutoFit
    ws.Columns.AutoFit
 
cleanExit:
    Application.ScreenUpdating = True
    Exit Sub
 
ErrHand:
    'Add error handler
    Resume cleanExit
End Sub