bonjour,

j'ai "bidouillé" une macro grâce à plusieurs codes trouvés sur divers forums, et sa fonction principale est remplie puisqu'elle créé bien des RDV dans un calendrier partagé depuis un tableau excel.
Le plus gros problème, c'est que quand je lance cette macro, ça m'ouvre à nouveau outlook (déjà ouvert sur mon ordinateur), et dans cette fenêtre, seul mon calendrier perso est affiché, alors que le RDV s'enregistre bien dans le calendrier partagé.
J'aimerais que ça n'ouvre plus cette fenêtre outlook quand je lance la macro, quelqu'un peut-il m'aider svp ?
(précision : je n'y connais pas grand chose, je n'arrive pas à comprendre à quoi correspondent les codes. il y a aura donc certainement des choses en "trop" dans ma macro)

Merci par avance à ceux qui m'aideront

voila le code que j'utilise :

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
109
110
111
112
113
 
Sub essai_macro_5()
Dim DLig As Long, Lig As Long
Dim DateRdv As Date, FlgRdv As Boolean
Dim OutObj As Outlook.Application
Dim OutAppt As Outlook.AppointmentItem
Dim MyCalendar As Outlook.Items
Dim NS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
 
'Dim OL As Outlook.Application
Dim olns As Outlook.Namespace
Dim myRecipient As Outlook.Recipient
Dim myFolder As Outlook.Folder
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim objNavGroup As Outlook.NavigationGroup
Dim objNavFolder As Outlook.NavigationFolder
Dim objAppt As AppointmentItem
 
Dim OL As Object
Dim OLmail As Object
 
 
Set OLk_Appli = CreateObject("Outlook.Application")
 
If OLk_Appli.Explorers.Count > 0 Then
'Ok outlook ouvert
Else
'mettre le bon chemin outlook
OLk_OK = Shell("C:\Program Files (x86)\Microsoft Office\Office15\outlook.exe", vbHide)
End If
 
Set OL = New Outlook.Application
Set olns = Outlook.Application.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = Outlook.Application.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "richard.XXX@XXXXXX.com" Then
'cas où le propriétaire du calendrier partagé fait l'opération
Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
Set Mysubfolder = myFolder.Folders("SRY Tomato Planning").Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
Set myRecipient = olns.CreateRecipient("richard.XXX@XXXXXX.com")
myRecipient.Resolve
If myRecipient.Resolved Then
Set Mysubfolder = objNavGroup.NavigationFolders("SRY Tomato Planning").Folder.Items
End If
End If
 
' Avec la feuille
With Sheets("Feuil1")
DLig = .Range("A" & Rows.Count).End(xlUp).Row
' Pour chaque ligne
For Lig = 2 To DLig
' Si une date existe
If .Range("D" & Lig) <> "" Then
' Si un RDV n'a pas déjà été créé
If .Range("K" & Lig) <> "" Then
' Si le commentaire a changé
If .Range("K" & Lig).Comment.Text <> .Range("H" & Lig).Value Then
FlgRdv = False
Else
' Sinon le commentaire n'a pas changé = pas de RDV
FlgRdv = False
End If
Else
' Sinon, pas de RDV déjà créé
FlgRdv = True
End If
Else
' Sinon, pas de date d'évènement
FlgRdv = False
End If
' Si le FLAG est à vrai on créé le RDV
If FlgRdv Then
DateRdv = Range("D" & Lig)
 
'Set OutAppt = MyCalendar.Add
'With OutAppt
Set OutAppt = Mysubfolder.Add
With OutAppt
.MeetingStatus = olMeeting
.Subject = Range("E" & Lig) & " - " & Range("F" & Lig) & " - " & Range("B" & Lig) & " - " & Range("D" & Lig)
.Start = Range("D" & Lig) & " 06:00"
.Duration = 60
.ReminderSet = True
.ReminderMinutesBeforeStart = 60 * 24 * Range("I" & Lig)
.Categories = Range("C" & Lig)
.Location = Range("G" & Lig)
.Body = Range("H" & Lig)
.RequiredAttendees = Range("J" & Lig)
.Send
.Save
End With
' Créer le commentaire et inscrire Oui
On Error Resume Next
.Range("K" & Lig).Comment.Delete
.Range("K" & Lig).AddComment
.Range("K" & Lig).Comment.Text Text:=Range("H" & Lig).Value '& Chr(10) & Format(Date, "dd mmmm yyyy")
.Range("K" & Lig) = "Oui"
On Error GoTo 0
End If
Next Lig
End With
Set OutAppt = Nothing
 
 
 
 
End Sub