Créer des rappels dans outlook

Bonjour,

Novice complet, je viens d'utiliser ce code pour mon tableau. Le code marche parfaitement et les rappels sont crées dans mon calendrier outlook.

Mais dans mon tableau j'ai 2 informations à vérifier, à deux dates différentes.

Je ne sais pas comment doubler le code pour qu'il enregistre des rappels aux deux dates...

Si quelqu'un peut m'aider?

Merci

(le nom de la société est dans la colone B le mail dans E les dates dans N et R et la validation du rdv sur outlook dans Q et S)

Dim Lig As Long
Dim OutObj As Object, OutAppt As Object
Dim DateRdv As Date, FlgRdv As Boolean
Dim sFilter As String
Dim oAppointment As Outlook.AppointmentItem

Dim namespaceOutlook As Outlook.Namespace
Dim DossierCalendrier As Outlook.MAPIFolder

  ' Créer une instance d'Outlook
 Set OutObj = CreateObject("outlook.application")
 Set namespaceOutlook = OutObj.GetNamespace("MAPI")

 Set DossierCalendrier = namespaceOutlook.GetDefaultFolder(olFolderCalendar)
  ' Avec la feuille
 With Sheets("Suivi")
    Lig = ActiveCell.Row
      ' Si une date de relance existe
     If .Range("B" & Lig) <> "" Then
        ' Si un RDV n'a pas déjà été créé
       If .Range("S" & Lig) <> "" Then
          ' Si le commentaire à changé
         If .Range("S" & Lig).Comment.Text <> .Range("E" & 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("R" & Lig)
        Set OutAppt = OutObj.CreateItem(1)
        sFilter = "[Subject] = 'Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig) & "' "
        Set oAppointment = DossierCalendrier.Items.Find(sFilter)

        If Not oAppointment Is Nothing Then
            With oAppointment
                .Subject = "Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig)
                .Start = DateRdv & " 08:00"
                .Duration = 60
                .ReminderSet = True
                .Save
            End With
        Else
            With OutAppt
              .Subject = "Rappeler " & Sheets("Suivi").Range("B" & Lig) & " au " & Sheets("Suivi").Range("E" & Lig)
              .Start = DateRdv & " 08:00"
              .Duration = 60
              .ReminderSet = True
              .Save
            End With
        End If

        ' Créer le commentaire et inscrire Oui
       On Error Resume Next
        .Range("S" & Lig).Comment.Delete
        .Range("S" & Lig).AddComment Text:=.Range("C" & Lig).Value
        .Range("S" & Lig) = "Oui"
        On Error GoTo 0
      End If

  End With
  Set OutAppt = Nothing

Bonjour,

Mais dans mon tableau j'ai 2 informations à vérifier, à deux dates différentes.

Je ne sais pas comment doubler le code pour qu'il enregistre des rappels aux deux dates...

Et sans fichier comment veux-tu que l'on fasse

On devine ou sont ces informations...

Désolée, en mettant les colonnes j'ai cru que ça suffirait

Re,

Je reconnais le code que j'avais créé pour une autre demande

Il est totalement à adapter pour ta situation

Voici ce que j'ai mis dans ton fichier joint

Sub AjoutRV()
  Dim Ind As Integer, Lig As Long
  Dim OutObj As Object, OutAppt As Object, Sht As Worksheet
  Dim DateRdv As Date
  Dim sFilter As String
  Dim IndRdV As Integer
  Dim TabColDate() As String, TabColRappel() As String
  Dim oAppointment As Outlook.AppointmentItem
  Dim NameSpaceOutlook As Outlook.Namespace
  Dim DossierCalendrier As Outlook.MAPIFolder
  ' Remplir les tableaux des colonnes
  TabColDate = Split("N,R", ",")
  TabColRappel = Split("Q,S", ",")
  ' Définir la feuille de travail
  Set Sht = ThisWorkbook.Sheets("Suivi")
  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  Set NameSpaceOutlook = OutObj.GetNamespace("MAPI")
  Set DossierCalendrier = NameSpaceOutlook.GetDefaultFolder(olFolderCalendar)
  ' Avec la feuille
  Lig = ActiveCell.Row
  ' Pour chaque colonne de RDV
  For IndRdV = 0 To UBound(TabColDate)
    ' Récupérer la date de RDB
    DateRdv = Sht.Range(TabColDate(IndRdV) & Lig)
    ' Vérifier que RDV existe, sinon passer à la colonne suivante
    If DateRdv = DateValue("00:00:00") Then GoTo SuiteIndRDV
    ' Vérifier si RDV n'existe pas déjà
    Set OutAppt = OutObj.CreateItem(1)
    sFilter = "[Subject] = 'Rappel à " & Replace(Sht.Range("B" & Lig), "'", "''") & _
      " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV)) & "' "
    Set oAppointment = DossierCalendrier.Items.Find(sFilter)
    ' Si existe déjà, le modifier
    If Not oAppointment Is Nothing Then
      With oAppointment
        .Subject = "Rappel à " & Sht.Range("B" & Lig) & " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    Else  ' Sinon le créer
      With OutAppt
        .Subject = "Rappel à " & Sht.Range("B" & Lig) & " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    End If
    ' Inscrire Oui, le commentaire ne sert à rien
    'On Error Resume Next
    'Sht.Range(TabColRappel(IndRdV) & Lig).Comment.Delete
    'Sht.Range(TabColRappel(IndRdV) & Lig).AddComment Text:=Sht.Range("C" & Lig).Value
    Sht.Range(TabColRappel(IndRdV) & Lig) = "Oui"
    'On Error GoTo 0
SuiteIndRDV:
  Next IndRdV
  ' Effacer les variables objet
  Set Sht = Nothing
  Set OutAppt = Nothing: Set NameSpaceOutlook = Nothing: Set DossierCalendrier = Nothing
End Sub

A+

Oui je l'ai copié d'un poste auquel j'ai répondu, sans réponse j'ai décidé de lancer un nouveau sujet

Je teste et je reviens vers toi, merci

Erreur compilation projet ou bibliotheque introuvable

(ci joint une capture d'écran)

sans titre

Re,

J'ai un office 2016 et tu dois avoir une autre version

Référence "Microsoft Outlook" à cocher dans les références VBAPRoject

Et décocher celle ou il est indiqué "[MANQUANTE]"

A+

En effet j'avais une manquante je ne savais pas ce que ça voulait dire, c'était pourtant clair...

Zut flute...

sans titre

Re,

Essaye plutôt ce code alors (déclaration en Late Binding)

Const olFolderCalendar As Long = 9

Sub AjoutRV()
  Dim Ind As Integer, Lig As Long
  Dim OutObj As Object, OutAppt As Object, Sht As Worksheet
  Dim OutApptFind As Object
  Dim NameSpaceOutlook As Object  'Outlook.Namespace
  Dim DossierCalendrier As Object   ' Outlook.MAPIFolder

  Dim DateRdv As Date
  Dim sFilter As String
  Dim IndRdV As Integer
  Dim TabColDate() As String, TabColRappel() As String
  ' Remplir les tableaux des colonnes
  TabColDate = Split("N,R", ",")
  TabColRappel = Split("Q,S", ",")
  ' Définir la feuille de travail
  Set Sht = ThisWorkbook.Sheets("Suivi")
  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  Set NameSpaceOutlook = OutObj.GetNamespace("MAPI")
  Set DossierCalendrier = NameSpaceOutlook.GetDefaultFolder(olFolderCalendar)
  ' Avec la feuille
  Lig = ActiveCell.Row
  ' Pour chaque colonne de RDV
  For IndRdV = 0 To UBound(TabColDate)
    ' Récupérer la date de RDB
    DateRdv = Sht.Range(TabColDate(IndRdV) & Lig)
    ' Vérifier que RDV existe, sinon passer à la colonne suivante
    If DateRdv = DateValue("00:00:00") Then GoTo SuiteIndRDV
    ' Vérifier si RDV n'existe pas déjà
    Set OutAppt = OutObj.CreateItem(1)
    sFilter = "[Subject] = 'Rappel à " & Replace(Sht.Range("B" & Lig), "'", "''") & _
      " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV)) & "' "
    Set OutApptFind = DossierCalendrier.Items.Find(sFilter)
    ' Si existe déjà, le modifier
    If Not OutApptFind Is Nothing Then
      With OutApptFind
        .Subject = "Rappel à " & Sht.Range("B" & Lig) & " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    Else  ' Sinon le créer
      With OutAppt
        .Subject = "Rappel à " & Sht.Range("B" & Lig) & " - Mail : " & Sht.Range("E" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    End If
    ' Inscrire Oui, le commentaire ne sert à rien
    'On Error Resume Next
    'Sht.Range(TabColRappel(IndRdV) & Lig).Comment.Delete
    'Sht.Range(TabColRappel(IndRdV) & Lig).AddComment Text:=Sht.Range("C" & Lig).Value
    Sht.Range(TabColRappel(IndRdV) & Lig) = "Oui"
    'On Error GoTo 0
SuiteIndRDV:
  Next IndRdV
  ' Effacer les variables objet
  Set Sht = Nothing
  Set OutAppt = Nothing: Set NameSpaceOutlook = Nothing: Set DossierCalendrier = Nothing
End Sub

A+

C'est parfait!

Merci!

(Faut que j'apprenne à faire ce genre de choses!)

Bonjour,

Je remonte mon sujet car je travaille sur le meme code sur un nouveau document.

j'ai donc

Const olFolderCalendar As Long = 9

Sub AjoutRV()
  Dim Ind As Integer, Lig As Long
  Dim OutObj As Object, OutAppt As Object, Sht As Worksheet
  Dim OutApptFind As Object
  Dim NameSpaceOutlook As Object  'Outlook.Namespace
  Dim DossierCalendrier As Object   ' Outlook.MAPIFolder

  Dim DateRdv As Date
  Dim sFilter As String
  Dim IndRdV As Integer
  Dim TabColDate() As String, TabColRappel() As String
  ' Remplir les tableaux des colonnes
  TabColDate = Split("F", ",")
  TabColRappel = Split("J", ",")
  ' Définir la feuille de travail
  Set Sht = ThisWorkbook.Sheets("AMPUS")
  ' Créer une instance d'Outlook
  Set OutObj = CreateObject("outlook.application")
  Set NameSpaceOutlook = OutObj.GetNamespace("MAPI")
  Set DossierCalendrier = NameSpaceOutlook.GetDefaultFolder(olFolderCalendar)
  ' Avec la feuille
  Lig = ActiveCell.Row
  ' Pour chaque colonne de RDV
  For IndRdV = 0 To UBound(TabColDate)
    ' Récupérer la date de RDB
    DateRdv = Sht.Range(TabColDate(IndRdV) & Lig)
    ' Vérifier que RDV existe, sinon passer à la colonne suivante
    If DateRdv = DateValue("00:00:00") Then GoTo SuiteIndRDV
    ' Vérifier si RDV n'existe pas déjà
    Set OutAppt = OutObj.CreateItem(1)
    sFilter = "[Subject] = 'Rappel à " & Replace(Sht.Range("A" & Lig), "'", "''") & _
      " - Mail : " & Sht.Range("B" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV)) & "' "
    Set OutApptFind = DossierCalendrier.Items.Find(sFilter)
    ' Si existe déjà, le modifier
    If Not OutApptFind Is Nothing Then
      With OutApptFind
        .Subject = "Rappel à " & Sht.Range("A" & Lig) & " - Mail : " & Sht.Range("B" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    Else  ' Sinon le créer
      With OutAppt
        .Subject = "Rappel à " & Sht.Range("A" & Lig) & " - Mail : " & Sht.Range("B" & Lig) & " - Pour : " & Sht.Cells(1, TabColDate(IndRdV))
        .Start = DateRdv & " 08:00"
        .Duration = 60
        .ReminderSet = True
        .Save
      End With
    End If
    ' Inscrire Oui, le commentaire ne sert à rien
    'On Error Resume Next
    'Sht.Range(TabColRappel(IndRdV) & Lig).Comment.Delete
    'Sht.Range(TabColRappel(IndRdV) & Lig).AddComment Text:=Sht.Range("C" & Lig).Value
    Sht.Range(TabColRappel(IndRdV) & Lig) = "Oui"
    'On Error GoTo 0
SuiteIndRDV:
  Next IndRdV
  ' Effacer les variables objet
  Set Sht = Nothing
  Set OutAppt = Nothing: Set NameSpaceOutlook = Nothing: Set DossierCalendrier = Nothing
End Sub

Cette ligne me pose problème

Set Sht = ThisWorkbook.Sheets("AMPUS")

En effet je souhaite utiliser le code sur tout le classeur et chaque page à un nom différent. J'ai beau chercher je n'y arrive pas.

Quand je remplace par ActiveSheet ou toute autre formule trouvée sur le net ça me met en erreur...

Merci d'avance.

Salut

As tu essayé

Set Sht = ThisWorkbook.ActiveSheet

A+

C'était si simple...

Merci!!

Par contre

Je suis obligée de faire ligne par ligne pour effectuer la macro, c'est normal?

Re,

Tout dépend de ce que tu veux faire exactement et comment c'est développé

Un petit fichier anonymisé

voila l'onglet modèle.

En gros j'en ai un par commune (une 40ène)

certaines lignes n'ont pas de date de rappel (déjà passé ou non pertinent)

Du coup j'aimerai que si la colonne "date de rappel" est remplie, la macro s'effectue sur la ligne, sinon et bien il n'y a pas besoin.

Le tableau est en train d'évoluer et finalement il y aura surement besoin d'une 2eme date de rappel sur la meme ligne (si la 2eme date de rappel est remplie aussi) du coup je vais reprendre le premier code.

Je me rend compte que j''explique tres mal au passage...

7test-macro.xlsx (13.96 Ko)

Je remonte le sujet, après recherches je me demande s'il vaut mieux :

- créer un tableau qui répertorie toutes les lignes de toutes les autres pages PUIS ajouter un code qui supprime les lignes si la colonne F n'est pas remplie.

- Trouver un code qui ne récupère que les lignes des autres feuilles lorsque F est remplie.

Dans tout les cas je ne sais pas le faire

Rechercher des sujets similaires à "creer rappels outlook"