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

[webels]

Bonjour. J'ai créé une macro qui me permet de placer des RV dans Outlook à partir d'un fichier excel, afin de gérer les dates de renouvellement de contrats.
J'ai de vagues notions VBA et j'ai pu la faire fonctionner grâce aux différents posts que j'ai trouvé sur le sujet (merci aux auteurs). Je mets le fichier en copie si quelqu'un veut en profiter. La macro fonctionne.

L'idée n'était pas d'envoyer des invitations, mais de placer directement le rv dans mon calendrier. J'ai quand même essayé de mettre un participant secondaire mais sans effet.

Ma préoccupation est que je souhaite placer les RV dans un calendrier secondaire, pas dans mon calendrier par défaut. Quand je regarder la liste des calendriers, je vois dans la section "Mes calendriers":
- Mon calendrier principal (click droit: emplacement: \\pdurant@xxx.com (mon adresse mail)
- un calendrier secondaire (emplacement: \\aaaaaaa (nom de la boîte partagée)
- anniversaires
....

Je ne trouve pas la solution pour placer les rv dans le calendrier secondaire.

Merci par avance à ceux qui pourraient m'aider.

Voici le code utilisé:

Sub RappelOutlook()
' Il est nécessaire de définir la référence : Microsoft Outlook 1X.0 Library
  Dim OutObj As Outlook.Application
  Dim OutAppt As Outlook.AppointmentItem
  Dim Sht As Worksheet
  Dim DLig As Long, Lig As Long, Sujet As String, Détail As String
  Dim sDate As String, Heure As String, HTemp As String
  Dim Delai As Integer, NbMois As Integer, Rappel As Single

  ' Récupérer les paramètres pour OUTLOOK
  Heure = Format(VParam("OutlookHeureR"), "hh:mm:ss") ' Heure de rappel
  Rappel = VParam("OutlookRappel")  ' Prévenir avant l'heure de
  Delai = VParam("OutlookDélaiRDV") ' Délai du RDV en minutes
  NbMois = VParam("MoisAvantEcheance")  ' Prévenir X mois avant échéance
  ' Demander l'heure de rappel au cas ou
  'HTemp = InputBox("A qu'elle heure voulez-vous faire le rappel (HH:MM) ?", "HEURE de RAPPEL ...", Heure)
 
  '  If InStr(1, HTemp, ":") > 0 Then Heure = Format(HTemp, "hh:mm:ss")
  'End If
  ' Définir la feuille source
  Set Sht = Sheets("Frais")
  ' Récupérer la dernière ligne du tableau
  DLig = Sht.Range("A" & Rows.Count).End(xlUp).Row
  ' Créer l'instance OUTLOOK
  Set OutObj = CreateObject("outlook.application")
  ' Pour chaque ligne sur la feuille
  For Lig = 2 To DLig
  If Sht.Range("I" & Lig).Value <> "X" Then
    ' Créer le sujet du mail
    Sujet = "Renouv. : " & Sht.Range("A" & Lig).Value & " - Contrat : " & Sht.Range("C" & Lig).Value
    ' Récupérer la date de fin de contrat
    sDate = Sht.Range("H" & Lig).Value
    ' Si aucune date, on passe à la ligne suivante
    If sDate = "" Then GoTo LigneSuivante
    ' Formater la date correctement
    sDate = Format(CDate(sDate) - (NbMois * 30.417), "dd/mm/yyyy")
    ' Créer l'instance pour le RDV
    Set OutAppt = OutObj.CreateItem(olAppointmentItem)
    ' Si tout est OK, on créé un RDV
    With OutAppt
      .Start = sDate & " " & Heure
      .Duration = Delai
      .Location = sDate
      .ReminderMinutesBeforeStart = Rappel * 60  ' rappeler 8 heure avant
      .ReminderSet = True
      .Subject = Sujet
      .Body = Détail
      .RequiredAttendees = VParam("attendee")
      '.Display
      .Send
      .Save
    End With
    ' Effacer la variable objet des RDV pour le prochain
    Set OutAppt = Nothing
    ' Mettre X pour indiquer que le RV est placé
    Sht.Range("I" & Lig).Select
    ActiveCell.FormulaR1C1 = "X"
   End If
    ' On continue
LigneSuivante:
  Next Lig
  ' Libérez la variable objet Outlook.
  Set OutObj = Nothing
  ' Petit message
  MsgBox "Le(s) Rendez-vous à/ont bien été ajouté ! ", vbInformation, "OK ..."
End Sub

 

[tomocam]

Bonjour Webels,

Ci-dessous un code que j'utilise pour permettre l'ajout dans un calendrier outlook secondaire (ou dans le mien).
Attention, les adresses des calendriers sont sensibles à la Casse.

En bonus, il permet d'utiliser l'instance d'outlook ouverte si c'est le cas

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

Tomo

 

[webels]

Bonjour. Merci beaucoup pour votre réponse. A ce stade, je ne parviens pas à faire fonctionner votre macro. J'ai une question:
- propriétaire du calendrier: faut-il laisser des ""? s'agit-il d'une adresse email ou du nom?
- nom calendrier partagé: même question

Merci
Eric

 

[tomocam]

Bonjour Eric,

Pour les propriétaires, il s'agit d'une adresse e-mail (sensible aux majuscules / minuscules). Il faut laisser les guillemets (idem pour calendrier partagé)

Tomo

 

[chich]

Bonjour Eric,

Pour les propriétaires, il s'agit d'une adresse e-mail (sensible aux majuscules / minuscules). Il faut laisser les guillemets (idem pour calendrier partagé)

Tomo

Bonjour

Je cherche à adapter à mon besoin votre code. Je souhaite que le nom du calendrier de destination du rdv concerné sois récupéré une boucle dans la colonne et la ligne d'un tableau excel pour chaque rdv. J'ai pu mettre en place la boucle, mais je rencontre des soucis avec cette ligne done ce message .

Incompatibilité de type (Erreur 13)​

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