Oliv-

Envoyé par Oliv-

Voici une solution quasi clef en main ! 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 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
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