Test présence RDV outlook

Y compris Power BI, Power Query et toute autre question en lien avec Excel
a
audrey54
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 21 juillet 2016
Version d'Excel : 2013

Message par audrey54 » 21 juillet 2016, 09:45

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
Avatar du membre
gelinotte
Membre dévoué
Membre dévoué
Messages : 600
Inscrit le : 29 juillet 2013
Version d'Excel : 2016

Message par gelinotte » 21 juillet 2016, 14:10

Bonjour,

Sur ce lien, http://forum.excel-pratique.com/excel/m ... 75464.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
Google est mon ami ...
a
audrey54
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 21 juillet 2016
Version d'Excel : 2013

Message par audrey54 » 21 juillet 2016, 14:17

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
Avatar du membre
gelinotte
Membre dévoué
Membre dévoué
Messages : 600
Inscrit le : 29 juillet 2013
Version d'Excel : 2016

Message par gelinotte » 21 juillet 2016, 17:37

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 :
http://www.rechercheunbondeveloppeur.co ... ec-vba.php


Gelinotte
Google est mon ami ...
a
audrey54
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 21 juillet 2016
Version d'Excel : 2013

Message par audrey54 » 26 juillet 2016, 09:02

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
a
audrey54
Nouveau venu
Nouveau venu
Messages : 7
Inscrit le : 21 juillet 2016
Version d'Excel : 2013

Message par audrey54 » 5 août 2016, 08:09

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
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message