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