envoyer une réunion avec la deuxième adresse mail depuis une macro Excel.
Bonjour le forum,
J'ai un programme Excel qui me permet de comparer l'emploi du temps de 2 personnes, puis lorsqu'un créneau est disponible, il envoi une demande de réunion. Il y a tout un tableau de rdv et cela s’exécute pour toutes les lignes.
Mon soucis, c'est qu'il y a 2 adresses mail de connectées, et je souhaite que la réunion soit créé avec le deuxième compte. C'est important parce que ce compte est utilisé pour la prise de rdv et ne pas polluer l'emploi du temps du compte principal. Ce 2ème compte peut être utilisé par plusieurs personnes.
J'ai essayé de plusieurs façons et plusieurs code en fouillant sur le web et le 2 techniques principales que j'ai trouvé sont :
- passer par la partie calendrier. Cad choisir le bon calendrier dessus puis ajouter la réunion.
- choisir le bon compte puis ajouter une réunion.
Dans les 2 cas je retombe toujours sur le compte principal (j'ai inversé les adresses mails et j'ai mis l'adresse pour la création de rdv en adresse principal et l'adresse de la personne, la mienne pour le coup, en second et j'ai encore créé sur l'adresse principal). Je suis sûr que c'est possible car manuellement je peux créer une réunion sur le bon calendrier mais je ne parviens pas à le coder. C'est pour quoi après avoir pas mal cherché, je me tourne vers vous le forum =).
Je vous met les codes que j'ai essayé avec quelques commentaires.
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
| Sub SendEmailFromSharedMailbox()
Dim olApp As Outlook.Application
Set olApp = Outlook.Application
Dim olNS As Outlook.Namespace
Dim objOwner As Outlook.Recipient
Set olNS = olApp.GetNamespace("MAPI")
Set objOwner = olNS.CreateRecipient("creation.rdv@outlook.com")
objOwner.Resolve
If objOwner.Resolved Then
'MsgBox objOwner.Name
Set newCalFolder = olNS.GetSharedDefaultFolder(objOwner, olFolderCalendar)
'Now create the email
Set olAppt = newCalFolder.Items.Add(olAppointmentItem)
With olAppt
'Define calendar item properties
.Start = "07/11/2020 2:00 PM"
.End = "07/11/2020 2:30 PM"
.Subject = "Appointment Subject Here"
.Recipients.Add ("personne.un@outlook.com")
'.SendUsingAccount = "creation.rdv@outlook.com" J'ai essayé en rajoutant cette ligne mais ça ne change rien pour la création de réunion. En revanche ça fonctionne quand il s'agit de mail ...
'Add more variables as required, eg reminder, importance, etc
.Display
End With
End If
End Sub |
Le deuxième code que j'ai essayé
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
157
158
159
160
161
162
|
Sub AjoutDansCalendrier(xCalendrier, xTitre, xHeurDeb, xDuree, xLieu, xBody, mailFormateur, mailNouvelArrivant, xTrouve)
'On Error Resume Next
'=======================================================================================
' Création d'un RDV sur Agenda OUTLOOK
'=======================================================================================
Dim olApp As Outlook.Application
Dim objNS As Outlook.Namespace
Dim objExpCal As Outlook.Explorer
Dim objNavMod As Outlook.CalendarModule
Dim ObjNavCalPart As Outlook.NavigationFolders
Dim objNavFolder As Outlook.NavigationFolder
Dim FolderPartage As Outlook.Folder
Dim F
'Dim xTrouve As Boolean
Set olApp = CreateObject("outlook.application")
Set objNS = olApp.Session
Set objExpCal = objNS.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
'--------------------------------------------------------------------------------------
' Parcours la liste des familles de calendrier et les calendriers de chaque famille
'--------------------------------------------------------------------------------------
xCalendrier = "Calendrier"
xTrouve = False
xNbrFamCal = objNavMod.NavigationGroups.Count
For F = 1 To xNbrFamCal
xNbrSousCal = objNavMod.NavigationGroups.Item(F).NavigationFolders.Count
For G = 1 To xNbrSousCal
If G = 1 And F = 1 Then
GoTo calendrier_suivant
End If
xNomFamilleCal = objNavMod.NavigationGroups.Item(F).Name
xNomCalendrier = objNavMod.NavigationGroups.Item(F).NavigationFolders.Item(G).DisplayName
If xNomCalendrier = xCalendrier Then
'On Error Resume Next
Set ObjNavCalPart = objNavMod.NavigationGroups.Item(xNomFamilleCal).NavigationFolders
Set objNavFolder = ObjNavCalPart(xCalendrier)
Set MonSousDoss = ObjNavCalPart(G)
'FoldName = MonSousDoss.Folder.Name & "-" & MonSousDoss.Folder.FullFolderPath
If Err Then
xTrouve = False
MsgBox "Calendrier : " & xCalendrier & " non accéssible !!!", vbCritical, "ERREUR"
Else
xTrouve = True
xMess = Empty
End If
Exit For
Else
xTrouve = False
End If
calendrier_suivant:
Next G
If xTrouve = True Then
Exit For
End If
Next F
'If xTrouve = False Then
' MsgBox "Calendrier : " & xCalendrier & " non trouvé !!!!", vbCritical, "CALENDRIER"
' Exit Sub
'End If
'--------------------------------------------------------------------------------------
' Suite
'--------------------------------------------------------------------------------------
If MonSousDoss <> Empty Then
Set FolderPartage = objNavFolder.Folder
On Error GoTo 0
'---------------------------------------------------------
' Création du RDV
'---------------------------------------------------------
Dim ObjRDV As Outlook.AppointmentItem
Set ObjRDV = FolderPartage.Items.Add
xStart = xHeurDeb
With ObjRDV
.Subject = xTitre
.SendUsingAccount = objNS.Session.Accounts.Item(2)
.MeetingStatus = olMeeting
.body = xBody
.Start = xStart
.Duration = xDuree 'Valeur entière (exemple 30) exprimée en minutes
.Location = xLieu
'.Send
Set myRequiredAttendee = ObjRDV.Recipients.Add(mailFormateur)
myRequiredAttendee.Type = olRequired
Set myOptionalAttendee = ObjRDV.Recipients.Add(mailNouvelArrivant)
myOptionalAttendee.Type = olRequired
If xLieu Like "*salle*" Or xLieu Like "*fgr*" Or xLieu Like "*sds*" Then
Set myResourceAttendee = ObjRDV.Recipients.Add(xLieu)
myResourceAttendee.Type = olRequired
End If
.Display 'Mettre en commentaire après mise au point
'.Save
End With
End If
End Sub |
Merci d'avance pour votre aide 8-)
