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
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