[XL-2016] Import meeting dans Outlook à partir d’Excel VBA

Bonjour,

J’ai un fichier Excel, une liste de meeting à importer dans Outlook. J’ai les colonnes suivantes :

A : Subject (dès que cette cellule est vide, mon programme considère que c’est la dernière ligne et s’arrête)
B : Location (vide possible)
C : Attendees Email (vide possible)
D : Date (error check dans le programme)
E : Heure debut (error check dans le programme)
F : Heure Fin (error check dans le programme)
G : éventuelle récurrence (numérique, vide possible et error check dans le programme)
H : période de l’éventuelle récurrence (D, W, M, vide possible, error check dans le programme, le meeting récurrent est set up de cette façon : tous les G période H)
I : Body (vide possible)
J : attachement (vide possible, error check dans le programme)
K : sub calendar (si vide, le meeting sera entré dans le calendrier par défaut)
L : Contol (quand le meeting est déjà entre, je mets Yes, et le programme skip, pour pouvoir relancer le programme sans dupliquer les meetings)

Ma macro marche parfaitement pour ce qui est d’importer un meeting, récurrent ou non, dans le calendrier par défaut. Pas de souci.

Mon problème se situe quand la colonne K n’est pas vide, autrement dit que le calendrier dans lequel je dois importer le meeting n’est pas le calendrier par défaut. (lignes 50 à 59). Ca bug sur la ligne 54.

Rappel de la ligne 54 dans le code principal en bas

Code:

Set subFolder = CalFolder.Folders(SubCal)

Erreur:

Citation:

“The attempted operation has failed, an Object Could not be found”

J’imagine qu’il ne trouve pas mon calendrier, qui pourtant existe.

Pièce jointe 236658

Merci de votre aide!

Code:

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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
Sub NewMeet()
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
'Variable declarations
    Dim olApp As Outlook.Application
    Dim olAppItem As Outlook.AppointmentItem
    Dim r As Long
    Dim mysub, myStart, myEnd
    Dim olNs As Outlook.Namespace
    Dim oPattern As RecurrencePattern
    Dim CalFolder As Outlook.MAPIFolder
    Dim subFolder As Outlook.MAPIFolder
 
    Set olApp = GetObject("", "Outlook.Application")
    Set olApp = CreateObject("Outlook.Application")
 
 
 
ThisWorkbook.Sheets(1).Activate
Line = 3
'Scanning line by line to createnew meetings
Do While ThisWorkbook.Sheets(1).Cells(Line, 1) <> ""
    'If meeting already created, bypass
    If ThisWorkbook.Sheets(1).Cells(Line, 12) = "Yes" Then
        GoTo Bypass
    End If
    'Errorhandling on meeting dates and time
    If ThisWorkbook.Sheets(1).Cells(Line, 4) = "" Or ThisWorkbook.Sheets(1).Cells(Line, 5) = "" Or ThisWorkbook.Sheets(1).Cells(Line, 6) = "" Then
        MsgBox ("Line " & Line & " is missing timing data")
        GoTo Bypass
    End If
 
 
 
 
    MSubj = ThisWorkbook.Sheets(1).Cells(Line, 1) 'Subject
    MLoc = ThisWorkbook.Sheets(1).Cells(Line, 2) 'Location
    MBod = ThisWorkbook.Sheets(1).Cells(Line, 9) 'Body
    MList = ThisWorkbook.Sheets(1).Cells(Line, 3) 'Email list
    AttachPath = ThisWorkbook.Sheets(1).Cells(Line, 10) 'Attachementpath
    MRecu = ThisWorkbook.Sheets(1).Cells(Line, 7) 'Recurrence: evey
    MPerRecu = ThisWorkbook.Sheets(1).Cells(Line, 8) 'Recurrence: period
 
    MStart = DateValue(ThisWorkbook.Sheets(1).Cells(Line, 4).Value) + ThisWorkbook.Sheets(1).Cells(Line, 5).Value 'Start Date & Time
    MEnd = DateValue(ThisWorkbook.Sheets(1).Cells(Line, 4).Value) + ThisWorkbook.Sheets(1).Cells(Line, 6).Value 'End Date& time
 
 
If ThisWorkbook.Sheets(1).Cells(Line, 11) <> "" Then 'Case ofSubfolder
    SubCal = ThisWorkbook.Sheets(1).Cells(Line, 11)
    Set olNs = olApp.GetNamespace("MAPI")
    Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
    Set subFolder = CalFolder.Folders(SubCal)
    Set olAppItem = subFolder.Items.Add(olAppointmentItem)
Else 'If empty, default folder
    Set olAppItem = olApp.CreateItem(olAppointmentItem)
 
End If
 
 
'Creation of meeting with or without attachement
If AttachPath <> "" Then
        With olAppItem
            .Location = MLoc
            .Body = MBod
            .RequiredAttendees = MList
            .Start = MStart
            .End = MEnd
            .Subject = MSubj
            .Attachments.Add (AttachPath)
            .MeetingStatus = olMeeting
            .Location = MLoc
            .Body = MBod
        End With
Else
        With olAppItem
            .Location = MLoc
            .Body = MBod
            .RequiredAttendees = MList
            .Start = MStart
            .End = MEnd
            .Subject = MSubj
            .MeetingStatus = olMeeting
            .Location = MLoc
            .Body = MBod
        End With
End If
 
 
'Recurrent meeting setup or not
If MRecu = "" And MPerRecu = "" Then
    GoTo NoRec 'No recurrence
Else
    'Error handling on recurrence
    If MRecu = "" Or MPerRecu = "" Then
        MsgBox ("Recurrence Column G or H not filled completly")
        Set oPattern = Nothing
        GoTo Bypass
    End If
    If IsNumeric(MRecu) = False Then
        MsgBox ("Recurrence Column G needs to be numerical")
        Set oPattern = Nothing
        GoTo Bypass
    End If
    If MPerRecu <> "D" And MPerRecu <> "M" And MPerRecu <> "W" Then
        MsgBox ("Recurrence Column H needs to be D, W or M")
        Set oPattern = Nothing
        GoTo Bypass
    End If
 
'Recurrence: every x period
Set oPattern = olAppItem.GetRecurrencePattern
 
    If MPerRecu = "D" Then
        oPattern.RecurrenceType = olRecursDaily
        oPattern.Interval = MRecu
        Set oPattern = Nothing
    End If
    If MPerRecu = "W" Then
        oPattern.RecurrenceType = olRecursWeekly
        oPattern.Interval = MRecu
        Set oPattern = Nothing
    End If
    If MPerRecu = "M" Then
        oPattern.RecurrenceType = olRecursMonthly
        oPattern.Interval = MRecu
        Set oPattern = Nothing
    End If
 
End If
 
 
NoRec:
 
olAppItem.Save
olAppItem.Send
 
ThisWorkbook.Sheets(1).Cells(Line, 12) = "Yes"
 
Bypass:
 
 
 
If ThisWorkbook.Sheets(1).Cells(Line, 11) <> "" Then
    Set subFolder = Nothing
End If
 
    Set olAppItem = Nothing
    Set olApp = Nothing
 
    Line = Line + 1
 Loop
 
 
End Sub