Déplacer un message après envoi [Résolu]

[didier.aucun]

Bonsoir,
J'ai trouvé ce code qui permet de déplacer le message vers un dossier précis aprés etre envoyé .

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procédure : Application_ItemSend
' Auteur    : Dolphy35 - http://dolphy35.developpez.com/
' Date      : 07/05/2008
' Détail    : Déplace le mail envoyé vers le dossier "dolphy_essais"
'---------------------------------------------------------------------------------------
'
'Déclarations des objets
    Dim objNSpace As namespace
    Dim fldDestination As MAPIFolder
    'Test si l'élément envoyé est un E-mail
    If Not Item.Class = olMail Then Exit Sub
    'Instance des objets
    Set objNSpace = Application.GetNamespace("MAPI")
    Set fldDestination = objNSpace.Folders("Dossiers personnels").Folders("Boîte de réception").Folders("dolphy_essais")
    Set Item.SaveSentMessageFolder = fldDestination
 
    'Vide des instances
    Set objNSpace = Nothing
    Set fldDestination = Nothing
 
End Sub

Peut on le modifier afin de déplacer le message uniquement pour certain destinataires ?
le but est de trier certain message suivant le destinataire apres son envoi.

[carden752]

Bonjour,

Oui c'est possible, il suffit de trier le destinataire du message, je n'ai pas tester mais quelque chose du style

Code :

If Not Item.To = "nom_destinataire" Then Exit Sub

[didier.aucun]

oui ça marche en rajoutant cette ligne dans le code
mais pour filtrer plusieurs destinataires ?

[carden752]

Bonjour,

Les destinataires sont dans une catégorie, une liste de diffusion de ton carnet d'adresses, c'est une liste figée?
Si tel est le cas, tu fais la même commande en bouclant sur la liste.

[didier.aucun]

Mes destinataires sont dans une catégorie "Magasin".
j'ai essayé
If Not Item.to.Categories = "Magasin"
mais ça doit pas etre ça

[carden752]

Bonjour,

Pour accéder aux catégories des contacts

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub SetAffiliationForContacts()
    Dim ns As NameSpace
    Dim foldContact As Object 'Object -> Outlook 2003 - Folder -> Outlook 2007 et 2010    Dim itemContact As ContactItem
    Dim colItems As Outlook.Items
    Dim myProperty As Outlook.UserProperty
       
    Set ns = Application.GetNamespace("MAPI")
    Set foldContact = ns.GetDefaultFolder(olFolderContacts)
    Set colItems = foldContact.Items.Restrict("[MessageClass]='IPM.Contact'")
    
    For Each itemContact In colItems
If itemcontact.Email1Address=Item.To then 'Comparaison des adresses
        If itemcontact.categories="Magasin" Then   
'Transfert         
        end if
end if
Next
End Sub

Je pense sans avoir testé que quelque chose de ce style peut marcher.
Attention si le contact a plusieurs adresses :

Code :

1
2
3
itemcontact.Email1Address peut être 
itemcontact.Email2Address
itemcontact.Email3Address

[didier.aucun]

Bon je sèche
car le premier code s’exécute automatiquement puisque il est dans ThisOutlookSession
mais le second code Non.
en plus j'ai une erreur sur

Code :

If itemcontact.Email1Address=Item.To then 'Comparaison des adresses

[didier.aucun]

j'ai tenté de modifier le code pour traiter plusieurs destinataires.
j'ai séparé en deux le code.
le premier analyse le mail et les destinataires. si le destinataire est vrai je lui demande d’exécuter le programme Sub classermail()
le tout est placé dans ThisOutlookSession.
Tout se passe bien dans le traitement sauf à la ligne

Code :

Set item.SaveSentMessageFolder = fldDestination

où j'ai une erreur.

Pouvez vous m'aider ?

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
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'
'Déclarations des objets
    Dim objNSpace As NameSpace
    Dim fldDestination As MAPIFolder
    'Test si l'élément envoyé est un E-mail
    If Not item.Class = olMail Then Exit Sub
    'Test le nom du destinataire
    If item.To = "Adresse1" Then classermail Else MsgBox "Pas de classement"
    If item.To = "Adresse2" Then classermail Else MsgBox "Pas de classement"
End Sub
 
Sub classermail()
MsgBox "ClasserMail"
'Déclarations des objets
    Dim objNSpace As NameSpace
    Dim fldDestination As MAPIFolder
    'Instance des objets
    Set objNSpace = Application.GetNamespace("MAPI")
    Set fldDestination = objNSpace.Folders("Boîte aux lettres").Folders("Éléments envoyés").Folders("Magasin")
    Set item.SaveSentMessageFolder = fldDestination
    'Vide des instances
    Set objNSpace = Nothing
    Set fldDestination = Nothing
End Sub

Ha oui j’oubliai, je suis nul en VBA

[bbil]

Pas de message d'erreur ?

[didier.aucun]

Oui à la ligne

Code :

Set item.SaveSentMessageFolder = fldDestination

Erreur d’exécution '424':
Objet requis

[bbil]

ben il dit quoi ce message !

[didier.aucun]

Erreur d’exécution '424':
Objet requis

[bbil]

a oui ... ton objet item n'est déclaré nulle-part...

[didier.aucun]

j'ai rajouté

Code :

Dim item As Object

mantenant j'ai
Erreur d’exécution '91':
variable objet ou bloc With non définie

[bbil]

Envoyé par didier.aucun

j'ai rajouté

Code :

Dim item As Object

mantenant j'ai
Erreur d’exécution '91':
variable objet ou bloc With non définie

suffit pas de le déclarer .. il faut aussi lui affecter quelque chose...


essai de modifier la déclaration de ta fonction

Code :

Sub classermail( item as object)

et son appel :

Code :

...Then classermail  Item ...

[didier.aucun]

merci.
voici mon code modifié et ça marche
bon je suis sur qu'il y avait plus simple ?

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Private Sub Application_ItemSend(ByVal item As Object, Cancel As Boolean)
'
    'Test si l'élément envoyé est un E-mail
    If Not item.Class = olMail Then Exit Sub
    'Test le nom du destinataire
    If item.To = "Adresse1" Then Classermail item
    If item.To = "Adresse2" Then Classermail item
End Sub
 
Sub Classermail(item As Object)
MsgBox "ClasserMail"
'Déclarations des objets
    Dim objNSpace As NameSpace
    Dim fldDestination As MAPIFolder
    'Instance des objets
    Set objNSpace = Application.GetNamespace("MAPI")
    'Dossiers personnels\Éléments envoyés\Magasin
    Set fldDestination = objNSpace.Folders("Dossiers personnels").Folders("Éléments envoyés").Folders("Magasin")
    Set item.SaveSentMessageFolder = fldDestination
    'Vide des instances
    Set objNSpace = Nothing
    Set fldDestination = Nothing
End Sub