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.
je souhaite atteindre les calendriers de destination avec cette ligne qui plante que je ne parviens pas a adapté.
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 Subje 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
