Discussion :

[nanex69]

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

[QuestVba]

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 :

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

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.

[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!

[Oliv-]

Bonjour,

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

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

[nanex69]

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

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

[Oliv-]

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

[nanex69]

Bonjours,

ça marche!

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

[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

[Oliv-]

Ou avec redemption

[nanex69]

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.
Es-je fait une erreur?

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

[nanex69]

Salut à tous,

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

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