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 mails 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 codes 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 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.

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) 'j'ai essayé avec la fonction GetDefaultFolder mais sans succès non plus

'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 'Une fois cette ligne passée, j'ai ma réunion qui s'affiche, mais toujours sur le compte principal, quel qu'il soit.
    End With
 End If

End Sub

Voici le deuxième code que j'ai essayé :

 
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

Si quelqu'un à une idée ou une piste, merci d'avance =)