Envoi Mail avec ajout d'un suivi

Public Sub SendMail() Dim myMail As Outlook.MailItem Dim myOutlApp As Outlook.Application Set myOutlApp = New Outlook.Application Set myMail = myOutlApp.CreateItem(olMailItem) With myMail .To = "destinataire@mail.com" .Subject = "Mon sujet" .HTMLBody = "Corps du mail" .FlagRequest = "Follow up" 'Ajout drapeau pour Destinataire .Categories = "Rappel" 'Marque la categorie du mail .FlagStatus = olFlagMarked ' Est censsé ajouter le flag .FlagIcon = olRedFlagIcon ' Couleur du Flag, pas d'effet .Importance = olImportanceHigh .TaskSubject = "Call" 'Pas d'effet visible .TaskStartDate = Date 'Date de départ Aucun effet .TaskDueDate = #1/30/2020 4:00:00 PM# 'Date de Fin Aucun effet .FlagDueBy = DateAdd("d", 2, Date) ' Ajout delai pour la tache destinataire .ReminderSet = True 'Activation du Rappel .ReminderTime = #1/30/2020 4:00:00 PM# .Display End With Set myMail = Nothing Set myOutlApp = Nothing End Sub

Re,

Je me suis penché sur la solution de récupérer le mail après envoi dans le dossier "Eléments envoyés".
Voici les deux Sub:

1ere pour l'envoi du message
2eme pour récupérer et créer la tache+suivi

En revanche j'ai été obligé de marquer une pause avant la récupération, car sinon la tache+suivi n'est pas crée.
Peut être y-a t'il une autres solution.
De plus je boucle tant que le mail n'est pas envoyé, cela ne mange pas trop de ressource, mais je ne vois pas ce que je pourrai faire d'autre... (pas très corporate :D)

Pour la 2eme Sub, je n'ai pas trouver autres solutions que de compter le nombre d'items dans le dossier "Eléments Envoyé" est de définir le dernier mail par le nombre total d'Items. Un peu de la débrouille me semble t'il, peut être a t'il plus léger!?

Si vous avez des suggestions d'amélioration, je suis tout ouïe.

Ps: Le code fonctionne à ce stade

Code:

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
 
Public Sub SendMail()
 
    Dim myMail As Outlook.MailItem
    Dim myOutlApp As Outlook.Application
 
    Set myOutlApp = New Outlook.Application
    Set myMail = myOutlApp.CreateItem(olMailItem)
 
    With myMail
        .To = "destinataire@mail.com"
        .Subject = "Mon sujet"
        .HTMLBody = "Corps du mail"
        .Display
    End With
 
    Do Until myMail.Sent = False
        DoEvents
    Loop
    Application.Wait (Now + TimeValue("00:00:05"))
 
    RecupMailEnvoyer
 
    Set myMail = Nothing
    Set myOutlApp = Nothing
 
End Sub
 
Sub RecupMailEnvoyer()
 Dim MonOutlook As Object, MonMail As Object
 Dim myItem As Outlook.MailItem
 Dim x As String
 
 Set MonOutlook = CreateObject("Outlook.Application")
        With MonOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
        x = .Items.Count 'Permet de compter le nombre d'item et de l'enregistrer dans la variable
        Set MonMail = .Items(x) 'Permet de cibler le dernier mail envoyé
        End With
        If MonMail.Subject = "Mon sujet" Then
            With MonMail
                .MarkAsTask (olMarkTomorrow)
                .FlagRequest = "Follow up" 'Ajout drapeau pour Destinataire
                .Categories = "Rappel Prospects/Clients" 'Marque la categorie du mail
                .FlagStatus = olFlagMarked ' Ajouter le flag
                .FlagIcon = olRedFlagIcon ' Couleur du Flag, pas d'effet
                .Importance = olImportanceHigh
                .TaskSubject = "Nom du contact et sujet mail" 'Sujet
                .TaskStartDate = Date 'Date de départ Aucun effet
                .TaskDueDate = #1/30/2020 9:00:00 PM# 'Date de Fin Aucun effet
                .FlagDueBy = DateAdd("d", 2, Date) ' Ajout delai pour la tache destinataire
                .ReminderSet = True    'Activation du Rappel
                .ReminderTime = #1/30/2020 4:00:00 PM#
                .Save
            End With
        End If
End Sub