Test présence RDV outlook

Bonjour,

J'ai parcouru divers forums et tenter de faire une maccro me permettant de planifier à une date renseignée sur Excel un RDV Outlook. Jusque là tout va bien... Quand le RDV est créé, la colonne C s'incrémente d'un texte "OUI". J'ai une boucle qui permet de vérifier si la colonne C est "OUI" alors la macro ne créé rien. Or, la date peut changer (il s'agit de visite médicale où une fois passée, une nouvelle date viendra la remplacer pour la prochaine visite à venir) et auquel cas, il faut que la personne qui gérera le fichier modifie la date et enlève le "OUI". Ce qui n'est pas assez fiable.

Peut-on demander à Excel de tester s'il y a un RDV déjà existant pour un nom de sujet (le sujet est "calculé" dans la maccro) et à une date donnée (celle en colonne B)? Si oui, comment?

Voici le module en place :

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("Suivi")

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("C" & Lig) <> "Oui" Then

FlgRdv = True

Else

' Sinon, pas de RDV déjà créé

FlgRdv = False

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("B" & Lig)

Set OutAppt = OutObj.CreateItem(olAppointmentItem)

With OutAppt

.Subject = "Visite Médicale " & Sheets("Suivi").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("C" & Lig) = "Oui"

On Error GoTo 0

End If

Next Lig

End With

Set OutAppt = Nothing

End Sub

Je vous remercie par avance pour votre aide.

Bonne journée,

Audrey

Bonjour,

Sur ce lien, https://forum.excel-pratique.com/excel/module-vba-pour-supprimer-des-rendez-vous-sur-outlook-t75464.html

Tu trouveras la partie pour effacer un rendez-vous dans outlook. Pour l'effacer, le code doit le trouver; donc tester s'il existe ... tu devrais y trouver ton bonheur.

Gelinotte

Bonjour Gelinotte,

Je ne m'y connais pas trop mais en lisant, j'ai l'impression que cette maccro supprime tous les rendez-vous du calendrier. Or, je ne veux pas faire un reset du calendrier mais juste vérifier si le RDV qui devrait être crée ne l'est pas déjà à une date donnée avec un objet donné.

Ai-je mal compris la maccro sinon?

Cordialement,

Audrey

Bonjour,

Si une macro efface des rendez-vous, avant de l'effacer, elle doit le trouver >>> c'est que tu cherches à faire : savoir s'il existe.

Voici un autre lien avec des commentaires :

Gelinotte

Bonjour,

J'ai tenté avec un test mais cela ne marche pas dès la ligne mynameSpace. Ne connaissant pas le langage VBA, à quoi correspond cette donnée?

Voici le nouveau code que j'ai mis en place mais je ne suis vraiment pas sûre que j'ai mis les bons éléments au bon endroit malgré de nombreux essais...

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
Set OutObj = CreateObject("Outlook.Application")
Set myNameSpace = OutObj.GetNamespace("MAPI")
Set OutObj.ActiveExplorer.CurrentFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
Set outlookitems = OutObj.ActiveExplorer.CurrentFolder.Items
  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  ' Avec la feuille
  With Sheets("Suivi")
    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
Cpte = outlookitems.Count
For x = 1 To Cpte
If .outlookitems(x).Subject = "Visite Médicale " & Sheets("Suivi").Range("A" & Lig) & outlookitems(x).Start = DateRdv & " 08:00" Then
           FlgRdv = True
          Else
          ' Sinon, pas de RDV déjà créé
          FlgRdv = False
        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("B" & Lig)
        Set OutAppt = OutObj.CreateItem(olAppointmentItem)
        With OutAppt
          .Subject = "Visite Médicale " & Sheets("Suivi").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("C" & Lig) = "Oui"
        On Error GoTo 0
      End If
Next x
    Next Lig
  End With
  Set OutAppt = Nothing
End Sub

D'avance, merci pour votre aide.

Bonne journée,

Audrey

Bonjour,

N'ayant pas eu de réponse, j'ai tenté autre chose pour résoudre mon problème : envoyer un mail si la date en colonne C est à aujourd'hui mais le code que j'ai tenté de faire ne marche pas et je n'ai pas de message d'erreur. Quelque chose vous paraît incohérent?

Private Sub GestionMail()

    Dim ClientEmail As Object
    Dim Message As Object
    Dim Corps As String

    Set ClientEmail = CreateObject("Outlook.Application")
    Set Message = ClientEmail.CreateItem(0)

   If "c" = Now Then
    On Error Resume Next
    With Message
        .To = "destinataire@mail.com"
        .Subject = "aaa"
        .Body = "bbb"
        .Send
    End With
    On Error GoTo 0

    Set Message = Nothing
    Set ClientEmail = Nothing

End If
End Sub

Merci vraiment d'avance pour votre aide. Je suis vraiment perdue...

Audrey

Rechercher des sujets similaires à "test presence rdv outlook"