Discussion :

[gusping]

Bonjour à tous,

Je suis novice sur le VBA Outlook. Voici ce que je souhaite réaliser :

Lors de l'envoi d'un mail avec un objet contenant "diffusion", par exemple intitulé "diffusion XM356", je souhaiterai qu'un nouveau dossier "XM356" soit créé dans ma boîte mail;
et par la suite, que toutes les réponses contenant XM356 y soit rangées.

J'espère que c'est suffisamment clair.

Je vous remercie d'avance pour votre aide.

Guillaume

[Oliv-]

Bonsoir,
tu peux consulter la faq il y a des exemples qui correspondent en partie à ta demande

http://outlook.developpez.com/faq/?p...A_Deplace_mail
http://outlook.developpez.com/faq/?p...A#VBA_Move_Exp
http://outlook.developpez.com/faq/?p...A_CreateFolder

tu ne dis pas où tu veux créer ton dossier (dans boite de reception ?)
auras tu d'autres dossiers à créer est ce qu'il faut chercher XMxxx ou autre chose

les reponses doivent y etre rangées quand dès leurs arrivées ?

[gusping]

Bonsoir Oliv,merci de ton aide
Les dossiers doivent être rangés dans le dossier diffusion.
Oui les réponses doivent y être rangées des leur réception.
Ou via une macro de tri...
Merci de ton aide
Je regarde les liens
Guillaume

[Oliv-]

Voici une solution quasi clef en main testé sous OL2010 ! A l'envoi le programme test si la structure de nom de dossier est présente ici #XM et cherche le mot complet ici #XM346, puis le classe dans le sous-dossier (créé s'il n'existe pas) du dossier Diffusion se trouvant dans la boite de réception.

et à la réception classe les Emails contenant cette même structure de la même façon.

Code à copier dans ThisOutlookSession

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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'---------------------------------------------------------------------------------------
' Procedure : Application_ItemSend
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Crée un dossier lors de l'envoi et classe le mail
'---------------------------------------------------------------------------------------
'
    If Not Item.Class = olMail Then GoTo fin
    Dim DossierName, StructureDossierName
    StructureDossierName = "#XM"
    Dim objFolderDestination As MAPIFolder
    If InStr(1, Item.Subject, DossierName, vbTextCompare) Then
        DossierName = getDossierName(Item.Subject, StructureDossierName)
        Set objFolderDestination = getDestinationFolder("Diffusion", DossierName)
        Set Item.SaveSentMessageFolder = objFolderDestination
    End If
fin:
End Sub
 
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
'---------------------------------------------------------------------------------------
' Procedure : Application_NewMailEx
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Classe Les Emails a la reception dans le dossier si le sujet contient la structure #XM
'---------------------------------------------------------------------------------------
'
    Dim objFolderDestination As MAPIFolder
    Dim varEntryIDs
    Dim Item
    Dim i As Integer
    varEntryIDs = Split(EntryIDCollection, ",")
    For i = 0 To UBound(varEntryIDs)
        Set Item = Application.Session.GetItemFromID(varEntryIDs(i))
        If Not Item.Class = olMail Then GoTo fin
        Dim DossierName, StructureDossierName
        StructureDossierName = "#XM"
        DossierName = getDossierName(Item.Subject, StructureDossierName)
 
        If InStr(1, Item.Subject, DossierName, vbTextCompare) Then
            Set objFolderDestination = getDestinationFolder("Diffusion", DossierName)
            Item.Move objFolderDestination
        End If
    Next
fin:
End Sub
 
Function getDestinationFolder(ParentName, FolderName) As Folder
'---------------------------------------------------------------------------------------
' Procedure : getDestinationFolder
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Renvoi le sous dossier d'un dossier avec création
'---------------------------------------------------------------------------------------
'
    Dim objNS As NameSpace
    Dim objFolderParent As MAPIFolder
    Dim objFolderDestination As MAPIFolder
    On Error Resume Next
    Set objNS = Application.GetNamespace("MAPI")
    Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders(ParentName)
    If TypeName(objFolderParent) = "Nothing" Then
        Set objFolderParent = objNS.GetDefaultFolder(olFolderInbox).Folders.add(ParentName)
    End If
    Set objFolderDestination = objFolderParent.Folders(FolderName)
    If TypeName(objFolderDestination) = "Nothing" Then
        Set objFolderDestination = objFolderParent.Folders.add(FolderName)
    End If
    Set getDestinationFolder = objFolderDestination
End Function
 
Function getDossierName(Subject, Structure) As String
'---------------------------------------------------------------------------------------
' Procedure : getDossierName
' Author    : OCTU
' Date      : 03/04/2015
' Purpose   : Trouve dans le sujet le nom qui correspond au début #XM
'---------------------------------------------------------------------------------------
'
    OuCommenceAdresse = InStr(1, Subject, Structure, vbTextCompare)
    If OuCommenceAdresse > 0 Then
        fin = InStr(OuCommenceAdresse + Len(Structure), Subject, " ")
        If fin = 0 Then
            getDossierName = Mid(Subject, OuCommenceAdresse)
        Else
            getDossierName = Mid(Subject, OuCommenceAdresse, fin - OuCommenceAdresse)
        End If
    End If
 
End Function

Si on ne veut classer que les réponses (=conversation) on peut utiliser .SetAlwaysMoveToFolder dans Application_ItemSend et zapper la procédure Application_NewMailEx