Agir sur un mail s'il dépasse 20 jours d'ancienneté

Version imprimable

04/10/2017, 14h04
nanex69

Agir sur un mail s'il dépasse 20 jours d'ancienneté

Bonjour à tous,

Je suis en première année de BTS SIO ( développement) en alternance.
Dans mon service nous avons une boîte mail "global" ou nous recevons des demandes qui doivent être traitées en moins de 21 jours.
J'aimerais faire une règle qui déplace les mails qui ont été reçus depuis plus de 20 jours dans un dossier "URGENT".
Malheureusement les règles ne peuve agir que sur les mails au moment de leurs arrivés.
Je pense faire un script mais je ne sais pas par où commencer!
Pourriez-vous me donner des pistes?

Cordialement

Bonsoir,

Juste une petite aide car il faut quand même travailler un peu. Le code suivant te permet de récupérer la date de réception.
Code:

1 2 3 4 5 6 7 8 9 Sub LitMessagerie() Set olApp = CreateObject("Outlook.Application") Set olns = olApp.GetNamespace("MAPI") Set olxFolder = olns.GetDefaultFolder(olFolderInbox) On Error Resume Next For Each i In olxFolder.Items Debug.Print i.ReceivedTime Next End Sub
Après, c'est un jeu d'enfant.

05/10/2017, 08h01
nanex69

Bonjour et avant tous, merci pour ta réponse!
Je vais travailler sur ça et viendrai faire un retour si j'ai fini ou si je suis bloqué.
"Juste une petite aide car il faut quand même travailler un peu" et merci d'avoir su cerner ma demande! :D

Bonjour,

Voici une autre façon de faire avec un filtre , tu auras aussi besoin de la méthode .move de mailitem

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Sub Restrict_age_mail()
    Dim myNamespace As Outlook.NameSpace
    Dim myInboxItems As Outlook.Items
    Dim myItems As Outlook.Items
    Dim myItem As Object
 
    Set myNamespace = Application.GetNamespace("MAPI")
    Set myInboxItems = myNamespace.GetDefaultFolder(olFolderInbox).Items
    Set myItems = myInboxItems.Restrict("[ReceivedTime] < '" & DateAdd("d", -20, Date) & "'")
    MsgBox myItems.Count
    For Each myItem In myItems
        If (myItem.Class = olMail) Then
            MsgBox myItem.Subject & ": " & myItem.ReceivedTime
        End If
    Next
End Sub

Bonjour,

Je bloque un peu.
En effet je dois filtrer mes mails par âge (sa marche super merci!), mais aussi par sujet! Et là ça ne veut pas fonctionner.
J'ai essayé (ligne 16) avec une condition mais aussi avec .Restrict mais rien y fait.
Un petit coup de pouce ne serait pas de refus. :roll:
Par la suite je pense réexpédier les mails sur la même boite (ou modifier la date de réception si possible?) et ajouté au sujet '[URGENT]'
Est-ce réalisable?
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 Sub LitMessagerie() Dim olApp As Object Dim olns As Object Dim olxFolder As Object Dim olxDesFolder As Object Dim myItems As Outlook.Items Dim i As Object Set olApp = CreateObject("Outlook.Application") Set olns = olApp.GetNamespace("MAPI") Set olxFolder = olns.Folders(1).Folders("Boîte de réception").Items Set olxDesFolder = olns.Folders(1).Folders("Urgent") Set myItems = olxFolder.Restrict("[ReceivedTime] < '" & DateAdd("d", -30, Date) & "'") For Each i In myItems If (i.Class = olMail) And (i.Subject Like SIG) Then Debug.Print i.Subject & ": " & i.ReceivedTime & " " & DateDiff("d", i.ReceivedTime, Now) 'i.Move olxDesFolder End If Next End Sub
PS: J'ai essayé d'utilisé " DateDiff("d", i.ReceivedTime, Now) > 19 " pour filtrer les mail mais sans succès, Est-ce possible?

11/10/2017, 11h23
Oliv-

Salut je ne vois pas où est instancié SIG
Ajoutes en haut du module option compare text

Bonjours,

ça marche!

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
 
Sub LitMessagerie()
    Dim olApp As Object
    Dim olns As Object
    Dim olxFolder As Object
    Dim olxDesFolder As Object
    Dim myItems As Outlook.Items
    Dim i As Object
    Dim sujetItem As String
 
    sujetItem = "MAIL A TRAITER"
    Set olApp = CreateObject("Outlook.Application")
    Set olns = olApp.GetNamespace("MAPI")
    Set olxFolder = olns.Folders(1).Folders("Boîte de réception").Items
    'Set olxDesFolder = olns.Folders(1).Folders("Urgent")
    Set myItems = olxFolder.Restrict("[ReceivedTime] < '" & DateAdd("d", -30, Date) & "'")
 
    For Each i In myItems
        If (i.Class = olMail) And (i.Subject Like "*" & sujetItem & "*") Then
 
            i.Subject = "[URGENT]" & i.Subject
 
            Debug.Print i.Subject & ": " & i.ReceivedTime & "  " & DateDiff("d", i.ReceivedTime, Now)
            'i.Move olxDesFolder
        End If
    Next
End Sub

Maintenant je souhaite mettre en avant les mails en question, j'ai pensé à les renvoyer en modifiant le sujet pour ajouté [URGENT] mais je ne suis pas sur de mon coup.
(si mes collègues clic sur répondre :( )
y a-t-il une autre solution?

11/10/2017, 15h45
Oliv-

Tu peux créer un "dossier de recherche" et le mettre en favoris, ou alors changer l ordre de tri de l affichage pour afficher en premier les plus anciens ou alors ajouter un Catégorie et trier sur la colonne catégorie. En fait cela dépend si tu peux agir sur les boîtes de tes collègues ou si tu peux juste agir sur les mails. Si tu utilises cdo tu peux renvoyer un message en indiquant l expéditeur d origine
11/10/2017, 15h46
Oliv-

Ou avec redemption

J'ai un petit problème que je viens de remarquer.
Quand je lance le script (avec par exemple: " i. Subject = "[URGENT]" & i. Subject " dans ma boucle),
tous les mails ne sont pas traités (je fais le test avec 3 mails identiques et seul 1 ou 2 sons modifier)
alors que dans ma fenêtre d’exécution mon " Debug. Print i. Subject & ": " & i. ReceivedTime & " " & DateDiff("d", i. ReceivedTime, Now) " m'affiche bien mes 3 lignes. 8O
Es-je fait une erreur?
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 Sub LitMessagerie() Dim sujetItem As String sujetItem = "MAIL A TRAITER" Set olApp = CreateObject("Outlook.Application") Set olns = olApp.GetNamespace("MAPI") Set olxFolder = olns.Folders(1).Folders("Boîte de réception") Set olxDesFolder = olns.Folders(1).Folders("Urgent") Set myItems = olxFolder.Items.Restrict("[ReceivedTime] < '" & DateAdd("d", -30, Date) & "'") For Each i In myItems If (i.Class = olMail) And (i.Subject Like "*" & sujetItem & "*") Then i.Subject = "[URGENT]" & i.Subject Debug.Print i.Subject & ": " & i.ReceivedTime & " " & DateDiff("d", i.ReceivedTime, Now) End If Next End Sub

Finis

Salut à tous,

J'ai enfin finis et ça marche pas mal!
Pour ceux que ça intéresse voici la version finale:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
Sub LitMessagerie()
    Dim olns As Outlook.NameSpace
    Dim olxFolder As Outlook.Items
    Dim myItems As Outlook.Items
    Dim i As Object
    Dim nameMail As String
 
    nameMail = "critère de recherche"
 
    Set olns = Application.GetNamespace("MAPI")
    Set olxFolder = olns.Folders(1).Folders("Boîte de réception").Items
    Set myItems = olxFolder.Restrict("[ReceivedTime] < '" & DateAdd("d", -19, Date) & "'") 'Le filtre (changer -19 par la valeur de votre choix)
    Set olxDesFolder = olns.Folders(1).Folders("Urgent").Items
 
 
    For Each i In myItems
        If (i.Class = olMail) And (i.Body Like "*" & nameMail & "*") Then  'alternative recherche par sujet (i.Subject Like "*" & nameMail & "*")
            i.Subject = "URGENT  " & i.Subject    'Ajoute URGENT devant l'Objet
            i.Save 'Important: sauvegarde les modifications faites sur les mails
        End If
    Next
End Sub

Merci à Oliv- et QuestVba pour vôtres aides