Discussion :

[Adeline8]

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

[joe.levrai]

Bonjour,

il faut tester si une instance existe (et la récupérer le cas échéant), sinon on la crée


ma procédure générique que j'utilise dans tout utilitaire excel qui pilote outlook

Code :

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

1
2
3
4
5
6
7
8
Dim OlApp As Object ' outlook.application
Dim OlNmSpace As Object ' outlook.namespace
 
Sub InitialisationOutlook()
    On Error Resume Next: Set OlApp = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OlApp Is Nothing Then Set OlApp = CreateObject("Outlook.Application")
    Set OlNmSpace = OlApp.GetNamespace("MAPI")
End Sub

[Adeline8]

Bonjour joe.levrai,

merci de votre réponse.
à quel endroit dans mon code faut-il que j'insère votre code ? dois-je faire des adaptations à mon code ?
désolée je suis vraiment débutante

[joe.levrai]

tu supprimes la partie de ta procédure située entre la ligne 24 et 35 (incluse)

tu colles les lignes de code que je t'ai proposé à la place (sans les deux déclarations de variables au dessus de la procédure)
tu renommes mes variables (OlApp devient OutObj et OlNmSpace devient OlNs)

c'est la façon brute, mais la façon la plus simple pour toi.

[Adeline8]

j'ai fait tout ce que tu m'as dit, mais ça ne marche pas. enfin, la macro fonctionne toujours sans planter, mais le problème n'est pas résolu.

voilà ce que j'ai fait :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
 Dim OL As Object
 Dim OLmail As Object
 
 
 On Error Resume Next: Set OutObj = GetObject(, "Outlook.Application"): On Error GoTo 0
    If OutObj Is Nothing Then Set OutObj = CreateObject("Outlook.Application")
    Set olns = OutObj.GetNamespace("MAPI")
 
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)

[joe.levrai]

Oh la vilaine ligne 12 que je n'avais pas remarqué

Remplace "Outlook.Application" par ta variable représentant l'instance outlook que tu as récupéré (OutObj)

et si ça ne fonctionne toujours pas, remet ton code mais en entier, là on a juste une parte de ta nouvelle procédure