Création d'un rdv outlook à partir d'excel dans plusieurs calendriers

heparti

XLDnaute Occasionnel
Bonjour,

Je vous sollicite car j'ai une macro qui fonctionne très bien mais qui ne créé un rendez-vous que dans le calendrier outlook de la personne qui ouvre le fichier excel.

Je souhaiterait pouvoir adapter la macro de façon à pouvoir créer un rendez-vous également dans un autre calendrier pour lequel j'ai les droits d'accès en tant qu'éditeur.

Merci pour votre aide.

Voici la macro :

Code:
Option Explicit

Sub AjoutRV()
  Dim DLig As Long, Lig As Long
  Dim OutObj As Outlook.Application
  Dim OutAppt As Outlook.AppointmentItem
  Dim DateRdv As Date, FlgRdv As Boolean

  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  ' Avec la feuille
  With Sheets("2014")
    DLig = .Range("A" & Rows.Count).End(xlUp).Row
    ' Pour chaque ligne
    For Lig = 2 To DLig
      ' Si une date de relance existe
      If .Range("B" & Lig) <> "" Then
        ' Si un RDV n'a pas déjà été créé
        If .Range("N" & Lig) <> "" Then
          ' Si le commentaire à changé
          If .Range("N" & Lig).Comment.Text <> .Range("C" & Lig).Value Then
            FlgRdv = True
          Else
            ' Sinon le commentaire n'a pas changé = pas de RDV
            FlgRdv = False
          End If
        Else
          ' Sinon, pas de RDV déjà créé
          FlgRdv = True
        End If
      Else
        ' Sinon, pas de date de relance
        FlgRdv = False
      End If
      ' Si le FLAG est à vrai on créé le RDV
      If FlgRdv Then
        DateRdv = Range("G" & Lig)
        Set OutAppt = OutObj.CreateItem(olAppointmentItem)
        With OutAppt
          .Subject = "Rappeler " & Sheets("2014").Range("A" & Lig) & " pour " & Sheets("2014").Range("A" & Lig)
          .Start = DateRdv & " 08:00"
          .Duration = 60
          .ReminderSet = True
          .Save
        End With
        ' Créer le commentaire et inscrire Oui
        On Error Resume Next
        .Range("N" & Lig).Comment.Delete
        .Range("N" & Lig).AddComment Text:=.Range("C" & Lig).Value
        .Range("N" & Lig) = "Oui"
        On Error GoTo 0
      End If
    Next Lig
  End With
  Set OutAppt = Nothing
End Sub
 

heparti

XLDnaute Occasionnel
Re : Création d'un rdv outlook à partir d'excel dans plusieurs calendriers

Je reviens vous solliciter car cette macro ne fonctionne plus sans que ni la macro ni le tableau n'aient été modifiés.

Je tourne sous outlook 2010.

Pouvez-vous m'aider au moins sur le dysfonctionnement ?

Merci.
 
Haut Bas