XL 2013 Ajouter un rdv calendrier depuis excel via exchange

[estivill]

Bonjour à tous,
J'utilisais une macro que l'on m'a aidé à concevoir afin d'ajouter de manière automatisée des rdv sur mon calendrier Outlook.
Malheureusement je dois à présent passer par Exchange et ne peux plus passer par l'application outlook pour le faire. Mais je n'arrive pas à modifier la Macro en ce sens .....
Auriez vous des pistes ou solution ?

Merci d'avance du temps que vous accorderez à ma demande.

Vois la macro fonctionnelle avec l'application :

Sub Ajout_RDV()
derl = Range("B" & Rows.Count).End(xlUp).Row

For i = 4 To derl 'première ligne du tableau

Calendrier = ThisWorkbook.Sheets("Paramètres").Range("J3")
Titre = ThisWorkbook.Sheets("Liste Congés").Range("G" & i) & " " & ThisWorkbook.Sheets("Liste Congés").Range("B" & i)
RDVDate = ThisWorkbook.Sheets("Liste Congés").Range("C" & i)
Heure = ThisWorkbook.Sheets("Liste Congés").Range("I" & i)
Duree = ThisWorkbook.Sheets("Liste Congés").Range("L" & i)
Lieu = ""
Body = ""
Categorie = "Catégorie orange" 'couleur du rdv

If (ThisWorkbook.Sheets("Liste Congés").Range("B" & i) <> "") _
And (ThisWorkbook.Sheets("Liste Congés").Range("N" & i) = "") Then 'test si un export vers le calendrier outlook a éjà été réalisé

Call AjoutDansCalendrier(Calendrier, Titre, RDVDate, Heure, Duree, Lieu, Body, Categorie)

Range("N" & i).Value = Now 'Flag de création
End If

Next i
End Sub
Sub AjoutDansCalendrier(xCalendrier, xTitre, xDateDeb, xHeurDeb, xDuree, xLieu, xBody, xCatégorie)
'---------------------------------------------------------------------------------------
' 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)
'Set objNavCalPart = objNavMod.NavigationGroups.Item("Mes calendriers").NavigationFolders 'Famille Mes calendriers
'Set objNavCalPart = objNavMod.NavigationGroups.Item("Autres calendriers").NavigationFolders 'Famille Autres calendriers
'Set objNavCalPart = objNavMod.NavigationGroups.Item("Calendriers partagés").NavigationFolders 'Famille Calendriers partagés


'--------------------------------------------------------------------------------------
' Parcours la liste des familles de calendrier et les calendriers de chaque famille
'--------------------------------------------------------------------------------------
xTrouve = False
xNbrFamCal = ObjNavMod.NavigationGroups.Count
For F = 1 To xNbrFamCal
xNbrSousCal = ObjNavMod.NavigationGroups.Item(F).NavigationFolders.Count
For G = 1 To xNbrSousCal
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
' xMess = xMess & "FAMILLE = " & xNomFamilleCal & Chr(13) & Chr(13)
' xMess = xMess & Space(10) & "CALENDRIER = " & xNomCalendrier
' MsgBox xMess, vbInformation, "FAMILLE & CALENDRIER"
End If
Exit For
Else
xTrouve = False
End If
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 = xDateDeb & " " & Hour(xHeurDeb) & ":" & Minute(xHeurDeb) & ":00"
With ObjRDV
.Subject = xTitre
.Body = xBody
.Start = xStart
.Duration = xDuree 'Valeur entière (exemple 30) exprimée en minutes
.Location = xLieu
.Categories = xCatégorie 'Exemple : Catégorie Orange
.ReminderMinutesBeforeStart = 0
.ReminderSet = True
'.Display 'Mettre en commentaire après mise au point
.Save
End With
End If
End Sub