Discussion :

[bonjour0555]

Bonjour à tous,

je remercie d'avance toutes personnes pour leur aide.

Je vais essayer de résumer au mieux mon problème.

Dans une colonne (A) se trouve les actions de mon planning à réaliser.
Dans une 2e colonne (B) se trouve les adresses mail des personnes concernées par la tâche.
Sachant que les actions et l'adresse mail de la personne en charge de l'action sont sur la même ligne
En 3e colonne (C) se trouve la date d'échéance de l'action.

A partir de ça, j'aimerais que 3 jours avant la date d'échéance un mail soit envoyer à la personne concernée avec le nom de l'action dans le corps du mail.
Exemple pour la ligne 1 :
J'aimerais que si la date dans C1 arrive 3 jours, un mail à B1 soit envoyé avec l'action A1 dans le mail.

Pour envoyer le mail j'utilise la messagerie outlook

Bien sure j'ai une liste d'actions donc j'aimerais faire répéter le programme à toutes mes actions.

merci à tous

[ChristianBosch]

Salut,

Tout d'abord je te conseille de créer un tableau structuré pour stocker tes données, ce qui va avoir plusieurs avantages, le principal étant de transformer ton tableau en véritable objet et le manipuler comme une base via power query, et en suite cela va également simplifier et généraliser le devellopement VBA.

Apres il faut que tu fasse attention, il me semble que outlook n'aime pas trop le spam et l'envoi de trop de mails.

Sur ce principe je te conseille de coder comme ceci (avec outlook) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub SendMail()
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim MyTab As ListObject
Dim LR As ListRow
Dim MsgSent As Integer
Dim MsgFailed As Integer
 
MsgSent = 0
MsgFailed = 0
Set MyTab = Feuil1.ListObjects(1)
 
For Each LR In MyTab.ListRows
    If LR.Range(3) >= Date - 3 Or LR.Range(4) = "FAUX" Then
        strTo = LR.Range(2)
        strSubject = "Merci de changer l'objet"
        strBody = LR.Range(1)
        If SendActiveWorkbook(strTo, strSubject, , strBody) = True Then
             LR.Range(4) = "VRAI"
             MsgSent = MsgSent + 1
        Else
           MsgFailed = MsgFailed + 1
        End If
    End If
Next LR
 
If MsgFailed = 0 Then
    MsgBox ("Vous avez envoyé " & MsgSent & " mails")
Else
    MsgBox ("Vous avez envoyé " & MsgSent & " mails." & MsgFailed & " messages n'ont pas pu etre remis")
End If
End Sub
 
 
Function SendActiveWorkbook(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
On Error Resume Next
Dim appOutlook As Object
Dim mItem As Object
SendActiveWorkbook = False
On Error GoTo fin
Set appOutlook = CreateObject("Outlook.Application")
Set mItem = appOutlook.CreateItem(0)
 
With mItem
    .To = strTo
    .CC = strCC
    .Subject = strSubject
    .Body = strBody
    .Send
End With
 
Set mItem = Nothing
Set appOutlook = Nothing
SendActiveWorkbook = True
fin:
End Function

Il faut adapter en fonction de ta feuille et j'ai rajouté une colonne dans le tableau qui verifie si le mail à pas deja été envoyé, il faut également changer l'objet du mail ici c'est "Merci de changer l'objet"

Il faut également rajouter la référence Microsoft outlook object library

[bonjour0555]

Bonjour,

Tout d'abord merci pour votre réponse.

Si j'ai bien compris votre code à tous les endroits où vous avez mis un numéro (1), (2), (3) ou (4) je dois y insérer la plage de cellule qui correspond à ma colonne. Donc par exemple le (1) à ma colonne avec mes actions (A7:A123) etc... y compris dans ce cas Set MyTab = Feuil1.ListObjects(1) ?
Est ce que la macro va parcourir toutes les cellules et sera coordonnées avec les cellules de la même ligne ? Aucun décalage des cellules n'est possible ?

De plus je ne comprends pas trop quand vous dites "Il faut également rajouter la référence Microsoft outlook object library" ? N'est t-elle pas dans le code à la fin ?

Merci encore

[bonjour0555]

Rebonjour @ChristianBosch,

J'ai repris ton code en le modifiant (ci-dessous),

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
Sub SendMail()
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim MyTab As ListObject
Dim LR As ListRows
Dim MsgSent As Integer
Dim MsgFailed As Integer
 
Dim Planning As Worksheet
Set Planning = ActiveSheet
 
 
Set MyTab = ActiveSheet.ListObjects("Tableau2")
Set LR = MyTab.ListRows.Add
 
MsgSent = 0
MsgFailed = 0
 
 
For Each LR In MyTab.ListRows
    If LR.Range(4) >= Date - 3 Or LR.Range(5) = "FAUX" Then
        strTo = LR.Range(3)
        strSubject = "Rappel Tâche"
        strBody = LR.Range(1)
        If SendActiveWorkbook(strTo, strSubject, strBody) = True Then
             LR.Range(5) = "VRAI"
             MsgSent = MsgSent + 1
        Else
           MsgFailed = MsgFailed + 1
        End If
    End If
Next LR
 
If MsgFailed = 0 Then
    MsgBox ("Vous avez envoyé " & MsgSent & " mails")
Else
    MsgBox ("Vous avez envoyé " & MsgSent & " mails." & MsgFailed & " messages n'ont pas pu etre remis")
End If
End Sub
 
 
Function SendActiveWorkbook(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
On Error Resume Next
Dim appOutlook As Object
Dim mItem As Object
SendActiveWorkbook = False
On Error GoTo fin
Set appOutlook = CreateObject("Outlook.Application")
Set mItem = appOutlook.CreateItem(0)
 
With mItem
    .To = strTo
    .CC = strCC
    .Subject = strSubject
    .Body = strBody
    .Send
End With
 
Set mItem = Nothing
Set appOutlook = Nothing
SendActiveWorkbook = True
fin:
End Function

J'ai un problème au niveau de la ligne : For Each LR In MyTab.ListRows
uen erreur 13 s'affiche, je ne comprends pas pourquoi ?

merci d'avance

[ChristianBosch]

Salut, il faut enlever le "s" de listrows que tu as rajouté dans la déclaration : Dim LR As ListRows

Par contre je ne comprends pas pourquoi tu initialise la variable "planning" sur activesheet, si ta feuille est toujours la meme, utilises plutot son codename pour initialiser la variable MyTab.

Tu peux directement utiliser le codename pour appeler l'objet "worksheet". Exemple :

Au lieu de faire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

worksheet("planning").range("a1")

tu peux faire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

feuil1.range("a1")

"feuil1" étant le codename de ta feuille nomée "planning", le but est de simplifier le code mais aussi d'éviter les sources d'erreur. Ici si tu change le nom de ta feuille, ton code n'est pas impacté puisque le codename ne peut etre changé que par le devellopeur.

[bonjour0555]

j'ai toujours une erreur à la même ligne mais cette fois la 438
En effet, j'ai supprimé le code avec activesheet, il était effectivement inutile.
Par contre, je n'ai pas besoin de mettre les colonnes est ligne ? avec LR.Range(4) il prend directement la colonne 4 avec la même ligne que LR.Range(5)?
Merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Sub SendMail()
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim MyTab As ListObject
Dim LR As ListRow
Dim MsgSent As Integer
Dim MsgFailed As Integer
 
 
 
Set MyTab = ActiveSheet.ListObjects("Tableau2")
 
MsgSent = 0
MsgFailed = 0
 
 
For Each LR In MyTab.ListRow
    If LR.Range(4) >= Date - 3 Or LR.Range(5) = "FAUX" Then
        strTo = LR.Range(3)
        strSubject = "Rappel Tâche"
        strBody = LR.Range(1)
        If SendActiveWorkbook(strTo, strSubject, strBody) = True Then
             LR.Range(5) = "VRAI"
             MsgSent = MsgSent + 1
        Else
           MsgFailed = MsgFailed + 1
        End If
    End If
Next LR
 
If MsgFailed = 0 Then
    MsgBox ("Vous avez envoyé " & MsgSent & " mails")
Else
    MsgBox ("Vous avez envoyé " & MsgSent & " mails." & MsgFailed & " messages n'ont pas pu etre remis")
End If
End Sub
 
 
Function SendActiveWorkbook(strTo As String, strSubject As String, Optional strCC As String, Optional strBody As String) As Boolean
On Error Resume Next
Dim appOutlook As Object
Dim mItem As Object
SendActiveWorkbook = False
On Error GoTo fin
Set appOutlook = CreateObject("Outlook.Application")
Set mItem = appOutlook.CreateItem(0)
 
With mItem
    .To = strTo
    .CC = strCC
    .Subject = strSubject
    .Body = strBody
    .Send
End With
 
Set mItem = Nothing
Set appOutlook = Nothing
SendActiveWorkbook = True
fin:
End Function

[ChristianBosch]

Avec la boucle for et la variable LR tu vas boucler sur toutes les lignes de ton tableau, avec l'objet "Range" tu selectionne la colonne de ton tableau.

Donc dans ton itération "LR.range(4)" signifie 4ieme colonne de la ligne x du tableau MyTab et LR.range(5) signifie 5ieme colonne de la ligne x du tableau MyTab. Donc nous bouclons sur toute les valeurs des colonnes de ton tableau et a chaque fois on va déterminer, en fonction des valeurs, si il faut envoyer le mail ou pas.

Etant donné que la dimention du tableau est connue et stockée dans la variable tableau (listobject), l'iteration est différente en fonction de ton nombre de ligne de cet objet.

Pour ton erreur 438 c'est normal, quand tu declares LR c'est bien "ListRow" sans "s" car tu déclare un objet "Ligne" par contre quand tu boucle sur toutes les lignes du tableau il faut ecrire :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

for each LR in MyTab.ListRows

n'oublies pas le "s". Ici tu indique a ta boucle que tu veux parcourir toutes les lignes de ton tableau.

[bonjour0555]

D'accord, merci beaucoup. C'est maintenant plus clair !
Mon code fonctionne. Par contre, je n'ai pas changé "Il faut également rajouter la référence Microsoft outlook object library" comme vous me l'aviez dit au début.
Est ce que c'est vraiment nécessaire ?
Merci

[bonjour0555]

J'avais encore une question, le programme s'exécutera t-il tout seule tout les jours sans que je l'ouvre ?
En effet, quand je l'exécute actuellement, il me dit aucun mail envoyer car aucunes des dates arrivent à échéance.
Mais est ce que à J-3 il le fera tous seule ?

[ChristianBosch]

Si tu veux le lancer à chaque ouverture du classeur par exemple, il faut mettre ceci dans le code de ton "ThisWorkbook" :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Private Sub Workbook_Open()
Call SendMail
End Sub

[bonjour0555]

Et ce n'est pas possible que la macro s'exécute toute seule tous les jours sans ouvrir le doc ?

[ChristianBosch]

Bonjour,

Non impossible d'executer une macro sans ouvrir le classeur.

[bonjour0555]

Bonjour,

Après avoir réussi mon code, merci encore.

J'aimerais y rajouter un plus. En effet, lors de l'envoie du mail, je souhaiterais qu'une demande de tâche y soit insérer.
Je m'explique, le mail est envoyé 3 jours avant la tâche.
Je souhaiterais que quand la personne reçoit le mail, dedans il y est le nom de la tâche, l'explication (colonne 1) et que la tâche soit mis à la date d'échéance (colonne 4).

Je vous remercie d'avance,
Cordialement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
 
Sub SendMail()
 
Dim strTo As String
Dim strSubject As String
Dim strBody As String
Dim MyTab As ListObject
Dim LR As ListRow
Dim MsgSent As Integer
Dim MsgFailed As Integer
 
 
 
Set MyTab = ActiveSheet.ListObjects("Tableau2")
 
MsgSent = 0
MsgFailed = 0
 
 
For Each LR In MyTab.ListRows
    If LR.Range(4) - 3 <= Date Or LR.Range(5) = "FAUX" Then
        strTo = LR.Range(3)
        strSubject = "Rappel Tâche "
        strBody = "<html><body>Bonjour, &" _
 
 
        If SendActiveWorkbook(strTo, strSubject, strBody) = True Then
             LR.Range(5) = "VRAI"
             MsgSent = MsgSent + 1
        Else
           MsgFailed = MsgFailed + 1
        End If
    End If
Next LR
 
If MsgFailed = 0 Then
    MsgBox ("Vous avez envoyé " & MsgSent & " mails")
Else
    MsgBox ("Vous avez envoyé " & MsgSent & " mails." & MsgFailed & " messages n'ont pas pu etre remis")
End If
 
End Sub
 
 
Function SendActiveWorkbook(strTo As String, strSubject As String, Optional strBody As String) As Boolean
On Error Resume Next
Dim appOutlook As Object
Dim mItem As Object
SendActiveWorkbook = False
On Error GoTo fin
Set appOutlook = CreateObject("Outlook.Application")
Set mItem = appOutlook.CreateItem(0)
 
With mItem
    .To = strTo
    .Subject = strSubject
    .htmlbody = strBody
    .display
End With
 
Set mItem = Nothing
Set appOutlook = Nothing
SendActiveWorkbook = True
fin:
End Function

[bonjour0555]

J'ai trouvé le code ci-dessous sur un forum :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Function testOutlook()
 
Set myTask = myOut.CreateItem(olTaskItem)
'Affectation d'un Objet Tâche à myTask
 
With myTask
    .Subject = "Mon Sujet de Tâche"
'Le sujet peut venir d'une cellule Excel
    .DueDate = LR.Range(4)
'Pareil
    .Body = "Le texte de ma tâche"
End With
 
myTask.Save
End Function

Comment doit je faire pour l'intégrer dans mon autre macro ?
Puis je la rajouter à la fin sans rien toucher ?
Merci

[ChristianBosch]

Bonjour, c'est pareil. C'est la partie de création du mail (fonction "SendActiveWorkbook")

[bonjour0555]

Rebonjour,

J'ai fait mon programme pour ajouter une tâche, cependant, il ne reconnait pas les variables initaliser précedement.
A savoir strbody, strsubject et strTo, pouvez vous m'aidé ?
merci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
 
 
Function TACHETEST()
 
 
Dim myOlApp As Outlook.Application
Dim myItem As Outlook.TaskItem
 
Set myOlApp = New Outlook.Application
Set myItem = myOlApp.CreateItem(olTaskItem)
 
 
With myItem
    .Status = olTaskInProgress
    .Importance = olImportanceHigh
    .DueDate = strDate
    .Body = strBody
    .Subject = strSubject
    .Assign
    .Recipients.Add ("strTo")
    .Save
 
Set mItem = Nothing
Set appOutlook = Nothing
End With
End Function

.

[bonjour0555]

Rebonjour,

Je n'ai toujours pas réussi à mettre en place mes tâches.
J'ai découvert une fonction pouvant mettre un mail en tâche sur outlook.
Serait-il possible de rajouter un bout de code pour que dès que le destinataire l'ouvre ça génère une tâche ?

Je vous remercie d'avance,
cordialement