Microsoft 365 Placer un RV dans l'agenda Outlook sur calendrier secondaire

Sub AjoutRV()
    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


      ' Créer une instance d'Outlook
PreparerOutlook OutObj

Set ol = New Outlook.Application
Set olns = ol.Session
Set objExpCal = olns.GetDefaultFolder(olFolderCalendar).GetExplorer
Set objNavMod = objExpCal.NavigationPane.Modules.GetNavigationModule(olModuleCalendar)
Set objNavGroup = objNavMod.NavigationGroups.GetDefaultNavigationGroup(olPeopleFoldersGroup)
Set objAppt = ol.CreateItem(olAppointmentItem)
If olns.DefaultStore.DisplayName = "propriétaire du calendrier" Then
'cas où le propriétaire du calendrier partagé fait l'opération
    Set myFolder = olns.GetDefaultFolder(olFolderCalendar)
    Set Mysubfolder = myFolder.Items
Else
'cas où un autre utilisateur ayant les droits d'éditeur fait l'opération
   Set myRecipient = olns.CreateRecipient("propriétaire du calendrier")
       myRecipient.Resolve
    If myRecipient.Resolved Then
       Set Mysubfolder = objNavGroup.NavigationFolders("nom calendrier partagé").Folder.Items
    End If
End If

            DateRdv = ActiveWorkbook.ActiveSheet.Range("A1")
            Set OutAppt = Mysubfolder.Add
            With OutAppt
              .Subject = "Remise DEVIS "
              .Start = DateRdv & " 08:00"
              .Duration = 60
              .ReminderSet = True
              .Save
            End With
         
Set OutAppt = Nothing
End Sub

Private Sub PreparerOutlook(ByRef OutObj As Object)

'------------------------------------------------------------------------------------------------
'Ce code vérifie si Outlook est prt ˆ envoyer des emails... Et s'il ne l'est pas, il le prépare.
'------------------------------------------------------------------------------------------------

On Error Resume Next
    'vérification si Outlook est ouvert
    Set OutObj = GetObject(, "Outlook.Application")
   
    If (Err.Number <> 0) Then 'si Outlook n'est pas ouvert, une instance est ouverte
        Err.Clear
        Set OutObj = CreateObject("Outlook.Application")
       
        If (Err.Number <> 0) Then
            MsgBox "Une erreur est survenue lors de l'ouverture de Outlook..."
            Exit Sub
        Else
        End If
       
    Else    'si Outlook est ouvert, l'instance existante est utilisée
    End If

End Sub

Set Mysubfolder = objNavGroup.NavigationFolders(Cells(i, 6)).Folder.Items