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