XL 2019 Atteindre depuis excel plusieurs calendriers partagé outlook de destination

chich

XLDnaute Occasionnel
Bonjour et merci d'avance pour votre aide

J'ai trouvé cette macro qui permet de placer des rdv dans Outlook à partir d'une base de données excel qui contient dans chaque ligne les informations pour enregistrer les rdv , les évènements de tous mes contacts avec qui je partage un calendrier qui porte le nom le prénom et l'organisation de mes contacte.

Voilà où j'en suis dans l'adaptation a mon besoin.
VB:
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
    
        For i = 3 To ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
'            If Cells(i, 7) = "" And Cells(i, 9) = "" Then
                deb = CDate(Cells(i, 3))
                deb = deb & " " & CDate(Cells(i, 4))
                dur = (Cells(i, 5) - Cells(i, 4)) * 1440
                Sujet = (Cells(i, 2))
                agend = (Cells(i, 6))
      ' 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 = "aderesse mail" 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("aderesse mail")

       myRecipient.Resolve
    If myRecipient.Resolved Then
       Set Mysubfolder = objNavGroup.NavigationFolders(Cells(i, 6)).Folder.Items
    End If
            Set OutAppt = Mysubfolder.Add
            With OutAppt
            .Start = deb 'Date et Heure du début du RDV
            .Duration = dur 'Durée du RDV en minute
            .Subject = Sujet 'titre du RDV
            .Body = "Pour un essai" 'text du RDV
            .Location = "https://www.bing.com/maps?cc=fr"
            .ReminderSet = True
            .Save
            End With
      End If
     Next i
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

je souhaite atteindre les calendriers de destination avec cette ligne qui plante que je ne parviens pas a adapté.
Code:
Set Mysubfolder = objNavGroup.NavigationFolders(Cells(i, 6)).Folder.Items
 

Discussions similaires