VBA-Outlook: Classement mails envoyés vers sous-dossiers ?

**emeric72** · 17/05/2016, 12h25

Bonjour,

J'ai 3 boites mails sous-outlook: 2 boites mails partagées et une boite mail personnelle.

Je souhaite que pour chaque mail envoyé depuis les 2 boites mails partagées, tout mail envoyé se classe dans le sous répertoire "En attente" de la boite de réception sauf si j'ai choisie un autre répertoire de classement que celui du défaut via le bouton "Enregistrer l'élément envoyé dans"

Pour ma boite mail perso, la règle ne doit pas s'activer

Comment faire en VBA sous Outlook ?

Par avance, merci de votre aide

Exemple:

Boite mail1
* "Boite de réception"
** "En attente" => classement par défaut des mails envoyés
** "A traiter"
* "Eléments envoyés"

Boite mail2
* "Boite de réception"
** "En attente" => classement par défaut des mails envoyés
** "A traiter"
* "Eléments envoyés"

Boite mail perso
* "Boite de réception"
* "Eléments envoyés"

**Oliv-** · 17/05/2016, 12h51

Ça aurait été mieux dans le sous forum OUTLOOK VBA ;-)

Dans ThisOutlooKSession il faut utiliser l'événement item_send

Voici un exemple qui demande où classer le mail.

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'#######ENREGISTRER UNE COPIE ET OU #######
    If Item.DeleteAfterSubmit = False And _
       Item.SaveSentMessageFolder Like "*léments envoyés" Then
 
        Title = "Voulez-vous garder une copie de ce mail ?"
        prompt = Item.Subject + vbCr + vbCr + _
                 "[OUI] vous choisissez le répertoire, [NON] envoi sans garder de copie" + vbCr + vbCr + _
                 "[ANNULER] dans 'Sélectionner un dossier' envoi en gardant copie dans 'éléments supprimés'"
        copie = MsgBox(prompt, vbYesNoCancel + vbQuestion + vbDefaultButton2, Title)
        If copie = 2 Then
            Cancel = True
            ActiveMailWord Item
            GoTo fin
        End If
        If copie = vbNo Then
            Item.DeleteAfterSubmit = True
        Else
 
            Set objNS = Application.GetNamespace("MAPI")
            Set objFolder = objNS.PickFolder
            If TypeName(objFolder) = "Nothing" Then
                Set objNS = Application.GetNamespace("MAPI")
                Set objFolder = objNS.GetDefaultFolder(olFolderDeletedItems)
            End If
            Set Item.SaveSentMessageFolder = objFolder
            Set objFolder = Nothing
            Set objNS = Nothing
        End If
 
    End If
 
    '#######FIN #######
End sub

Il faut ensuite tester l'expéditeur et indiquer le dossier selon celui-ci

Code :

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

1
2
 
set objfolder= Application.Session.Stores("ma bal").GetDefaultFolder(olFolderInbox).folders("En attente")

**emeric72** · 17/05/2016, 13h34

merci Oliv mais je ne veux pas laisser le choix:

pseudo code souhaité:

Si (boite mail d'émission <> de ma boite personnelle) et ("Enregistrer mail envoyés dans" <> "utiliser le dossier par défaut"
alors
---> déplacer tout mail envoyé dans <boite mail d'émission\boite de réception\en attente> --> ne rien avoir dans "Eléments envoyés"
---> le marquer comme "Lu"
fin si

**Oliv-** · 17/05/2016, 14h25

Essaye ce code , le sous dossier "En attente" doit exister.

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OLiv-
' Date      : 17/05/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
 
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then GoTo fin
 
    '#######ENREGISTRER UNE COPIE ET OU #######
 
    If Item.SendUsingAccount.displayName <> Application.Session.DefaultStore.displayName Then
        If Item.DeleteAfterSubmit = False And _
           Item.SaveSentMessageFolder Like "*léments envoyés" Then
 
'on error resume next
            Set objFolder = Item.SendUsingAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Folders("En attente")
 
            If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If
            Set objFolder = Nothing
            Set objNS = Nothing
 
        End If
    End If
 
    '#######FIN #######
fin:
    Set Item = Nothing
 
End Sub

**emeric72** · 17/05/2016, 17h00

1) à quoi sert la variable valorisée à Item.DeleteAfterSubmit = False dant le test ?
2) je ne comprend pas pourquoi mon test en gras ne marche pas

Code VB :

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Dim repert As String
    
    
    
       
    Set objNS = Application.GetNamespace("MAPI")
    
    If Item.SendUsingAccount.DisplayName <> Application.Session.DefaultStore.DisplayName Then
      repert = "En attente"
    Else: repert = "Éléments envoyés"
    End If
    
    MsgBox repert
    
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then GoTo fin
   
   
    '#######ENREGISTRER UNE COPIE ET OU #######
 
    If (Item.SendUsingAccount.DisplayName <> Application.Session.DefaultStore.DisplayName) And (Item.SaveSentMessageFolder = "Éléments envoyés") Then


'on error resume next
            Set objFolder = Item.SendUsingAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Folders(repert)
 
            If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If
            Set objFolder = Nothing
            Set objNS = Nothing
 

    End If
 
    '#######FIN #######
fin:
    Set Item = Nothing
    
 
End Sub

**Oliv-** · 17/05/2016, 17h36

le Item.DeleteAfterSubmit = False c'est l'équivalent de "ne pas enregistrer" ca veut dire que manuellement on a fait ce choix.

qu'est ce qui ne marche pas dans ton test

Code :

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

1
2
3
4
If Item.SendUsingAccount.DisplayName <> Application.Session.DefaultStore.DisplayName Then
repert = "En attente"
Else: repert = "Éléments envoyés"
End If

le test lui même ou la choix du dossier ? selon moi c'est le choix du dossier car "Éléments envoyés" n'est pas un sous dossier de inbox.
tu n'es pas obligé de faire ce test, c'est forcèment "Éléments envoyés" dans l'autre cas avec mon code.

**emeric72** · 18/05/2016, 08h55

tu as raison Oliv

en fait, je ne veux pas que le pgm plante si le dossier "En attente" n'existe pas. Si "en attente" n'existe pas alors go to fin

**emeric72** · 18/05/2016, 10h40

c'est bon j'ai trouvé mon 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
24
25
26
27
28
29
30
31
32
33
34
35
36
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    
    Set objNS = Application.GetNamespace("MAPI")
    
   
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then GoTo fin
   
   
    '#######déplacer dans répertoire "en attente" par défaut sinon répertoite choisi #######
 
     If (Item.SendUsingAccount.DisplayName <> "Serveur Microsoft Exchange") Then
        If Item.DeleteAfterSubmit = False And _
         Item.SaveSentMessageFolder = "Éléments envoyés" Then

'on error resume next
            Set objFolder = Item.SendUsingAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Folders("En attente")
 
            If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If
            Set objFolder = Nothing
            Set objNS = Nothing
 
       End If
    End If
 
    '#######FIN #######
fin:
    Set Item = Nothing
    
 
End Sub

**emeric72** · 18/05/2016, 18h34

ça se complique un peu: le code fonctionne dans un contexte normal.

le problème est que mon entreprise a bridé le fonctionnement standard d'outlook à savoir:

tout mail envoyé est classé par défaut dans les éléments envoyés de la boite personnelle d'une personne y compris un mail envoyé depuis une boite partagée.
dans ce contexte, l'option "Enregistrer l'élément envoyé dans" ne fonctionne que pour les sous-dossiers de la boite personnelle et le code VBA ne fonctionne donc plus dans ce contexte.

en l'occurence les variables Item.SendUsingAccount.DisplayName , Application.Session.DefaultStore.DisplayName, Item.SendUsingAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Folders("En attente"), etc correspondent dans tous les cas de figure à des paramètres de la boite de réception de la boite personnelle et jamais de la boite mail avec laquelle le mail est envoyé !

A mon avis il faut donc trouver l'adresse de la boite de réception correspondant au champ "De" Item.SentOnBehalfOfName avec lequel le mail est envoyé

et ça je ne sais pas faire

j'espère que je suis assez clair

merci d'avance

**emeric72** · 18/05/2016, 19h44

en fait, je veux forcer le classement du mail envoyé dans un sous dossier de la boite mail de Item.SentOnBehalfOfName

**Oliv-** · 19/05/2016, 11h14

Mon code doit fonctionner sans changement ! as tu essayé de le lancer tel quel ?

lorsque tu envoies un Mail à partir d'une des boites partagées, est ce que le destinataire reçoit un mail "de: cette boite" ou "De: cette boite de la part de TOI "

**emeric72** · 19/05/2016, 11h41

Envoyé par Oliv-

Mon code doit fonctionner sans changement ! as tu essayé de le lancer tel quel ?

lorsque tu envoies un Mail à partir d'une des boites partagées, est ce que le destinataire reçoit un mail "de: cette boite" ou "De: cette boite de la part de TOI "

bonjour Olivier,

je viens d'échanger avec l'expert outlook de mon entreprise.
En fait, je pense qu'il y a un pbm plus global:
les boites groupes (partagées) qui sont installées par automapping perdent les fonctionnalités standards d'outlook telle que:
* positionner par défaut l'adresse mail de la boite de récéption (groupe) sur laquelle on est positionné losqu'on clique sur "nouveau mail": le la valeur par défaut est l'adresse mail du compte principal de la boite personnelle. Il faut à chaque fois choisir l'adresse de la boite groupe dans la combo "De:"
* le bouton "enregistrer le message envoyé dans " est inacessible pour les boite groupes "automappées" => bouton grisé
* les codes catégories des boites groupes "automappées" ne peuvent être renommés
* l'ajout de dossiers de recherche est impossible dans les boites automappées
* le contexte par défaut est celui de la boite personnelle et pas celui de la boite groupe "automappée" sur laquelle on est positionné
* tout message envoyé est systématiquement classé dans élément envoyé de la boite personnelle et cela quel que soit la boite mail "automappée" émettrice => solution contournement Ok : modification des clé de registre DelegateSentItemStyle + DelegateWastebasketStyle
* etc.

si une boite partagée est installée manuellement par l'utilisateur, tout les pbms cités ci-dessus disparaissent!
donc avant de poursuivre dans les investigations, j'attend un retour de l'expert outlook de ma boite sur les solutions qu'il peut proposer pour contourner le pbm. Visiblement, il n'est pas favorable à supprimer l'installation des boites partagées par automapping

**Oliv-** · 19/05/2016, 12h53

J'ai effectivement le même problème selon où est configurée la bal partagée.

Essaye donc ce code qui prévoit les 2 cas

Si on peut trouver le nom de la boite selon le nom d'envoi(SentOnBehalfOfName), on peut mettre une règle sans indiquer en dur le nom de la bal et des dossiers , c'est l'objet du premier case

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
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OLiv-
' Date      : 17/05/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim prompt As String
    Dim taille, pieces
    Dim objNS As NameSpace
    Dim objFolder As MAPIFolder
    Set objNS = Application.GetNamespace("MAPI")
 
    ' on verifie que c'est un mail
    If Not Item.Class = olMail Then GoTo fin
 
    '#######ENREGISTRER UNE COPIE ET OU #######
 
    If Item.SentOnBehalfOfName <> "" And Item.SentOnBehalfOfName <> Application.Session.CurrentUser.Name Then
 
        If Item.DeleteAfterSubmit = False And _
           Item.SaveSentMessageFolder Like "*léments envoyés" Then
 
            On Error GoTo fin
            Select Case Item.SentOnBehalfOfName
            Case objNS.Folders(Item.SentOnBehalfOfName).Name 'automatique
                Set objFolder = objNS.Folders(Item.SentOnBehalfOfName).Folders("Boîte de réception").Folders("En attente")
            Case "BAL1"
                Set objFolder = objNS.Folders("BAL1").Folders("Boîte de réception").Folders("En attente")
            Case "BAL2"
                Set objFolder =  objNS.Folders("BAL2").Folders("Boîte de réception").Folders("En attente")
 
            End Select
 
            If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If
            Set objFolder = Nothing
            Set objNS = Nothing
 
        End If
    End If
 
    If Item.SendUsingAccount.displayName <> Application.Session.DefaultStore.displayName Then
        If Item.DeleteAfterSubmit = False And _
           Item.SaveSentMessageFolder Like "*léments envoyés" Then
 
            On Error GoTo fin
            Set objFolder = Item.SendUsingAccount.DeliveryStore.GetDefaultFolder(olFolderInbox).Folders("En attente")
 
            If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If
            Set objFolder = Nothing
            Set objNS = Nothing
 
        End If
    End If
 
    '#######FIN #######
fin:
    Set Item = Nothing
 
End Sub

**emeric72** · 19/05/2016, 15h18

il faut que je valorise en dur les noms de BAL1 et BAL2?

**Oliv-** · 19/05/2016, 15h27

pas si c'est le même nom

**emeric72** · 19/05/2016, 15h36

je ne comprends pas.

j'ai une boite perso "emeric@domaine.fr" qui est visible comme un compte exchange => visible dans le menu paramètre du compte de messagerie

Serveur: exchange.domaine.fr
Nom de l'utilisateur: emeric -> présent dans l'annuaire

2 boites partagées (bal1@domaine.fr et bal2@domaine.fr) déclarées en automapping => non visibles dans le menu paramètre du compte de messagerie

**Oliv-** · 19/05/2016, 16h17

Quand tu es dans l'explorer OUTLOOK avec tes BAL à GAUCHE.

Nom : Capture.PNG
Affichages : 1181
Taille : 2,0 Ko

chaque BAL est précédée d'un triangle.
En face du triangle c'est le nom de la BAL.

Si lorsque tu envois un mail DE: cette BAL le nom est le même que celui affiché devant le triangle tu n'a pas besoin de paramétrer en DUR le chemin de ton classement.

Essaye le code tel qul tu verras bien si cela marche, il faut juste que le sous dossier "En attente existe"

**emeric72** · 19/05/2016, 16h37

ça marche pas
le mail envoyé d'une boite partagée va dans "éléments envoyés" de la boite perso

il passe pourtant dans le 1er case

**Oliv-** · 19/05/2016, 17h39

est ce que le test suivant est passé ?

Code :

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

1
2
3
If Not TypeName(objFolder) = "Nothing" Then
                Set Item.SaveSentMessageFolder = objFolder
            End If

**Oliv-** · 19/05/2016, 17h43

change la clause select case
par ce code, comme sela si "en attente" n'existe pas il sera créé

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
On Error Resume Next
Select Case Item.SentOnBehalfOfName
            Case objNS.Folders(Item.SentOnBehalfOfName).Name
                Set objFolder = objNS.Folders(Item.SentOnBehalfOfName).Folders("Boîte de réception").Folders("En attente")
                If TypeName(objFolder) = "Nothing" Then
                    Set objFolder = oobjNS.Folders(Item.SentOnBehalfOfName).Folders("Boîte de réception").Folders.add("En attente")
                End If
            Case "BAL1"
                Set objFolder = objNS.Folders("BAL1").Folders("Boîte de réception").Folders("En attente")
            Case "BAL2"
                Set objFolder =  objNS.Folders("BAL2").Folders("Boîte de réception").Folders("En attente")
 
            End Select

VBA-Outlook: Classement mails envoyés vers sous-dossiers ? [OL-2010]

VBA Outlook

Discussions similaires

Partager

Partager