Si quelqu'un trouve ceci et se demande, j'ai pu le comprendre par moi-même. Je suis encore assez nouveau dans ce domaine, et je ne savais pas que je pouvais modifier la balise "Items" pour définir ce que je regardais, puis définir la nouvelle variable pour pointer vers son propre dossier. Une fois que j'ai fait ça, j'ai pu ajouter une sous-routine pour chaque dossier et j'ai réussi.
Private WithEvents Corporate As Outlook.Items
Private WithEvents Subsidiary As Outlook.Items
Private WithEvents ServDsk As Outlook.Items
Private WithEvents Vendors As Outlook.Items
Public Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
' définir la référence d'objet sur la boîte de réception par défaut
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set DefFol = objNS.GetDefaultFolder(olFolderInbox)
Set Corporate = DefFol.Folders("Corporate Teammates").Items
Set Subsidiary = DefFol.Folders("Subsidiary").Items
Set ServDsk = DefFol.Folders("Service Desk").Items
Set Vendors = DefFol.Folders("Vendors").Items
End Sub
Private Sub Corporate_ItemAdd(ByVal up As Object)
' se déclenche lorsque nouvel élément ajouté à la boîte de réception par défaut
' (par Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
Dim dirstr As String
Dim strDomain As String
' ne rien faire pour les éléments non-Mailitems
If TypeName(up) <> "MailItem" Then GoTo ProgramExit
Set Msg = up
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' déplacer l'e-mail reçu vers le dossier cible en fonction du nom de l'expéditeur
senderName = Msg.senderName
dirstr = "Corporate Teammates"
If CheckForFolder(senderName, dirstr) = False Then ' Le dossier n'existe pas
Set targetFolder = CreateSubFolder(senderName, dirstr)
Else
' Set olApp = Outlook.Application
' Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(senderName)
End If
Msg.UnRead = False
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & dirstr
Resume ProgramExit
End Sub
Private Sub Subsidiary_ItemAdd(ByVal up As Object)
' se déclenche lorsque nouvel élément ajouté à la boîte de réception par défaut
' (par Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
Dim dirstr As String
' ne rien faire pour les éléments non-Mailitems
If TypeName(up) <> "MailItem" Then GoTo ProgramExit
Set Msg = up
' déplacer l'e-mail reçu vers le dossier cible en fonction du nom de l'expéditeur
senderName = Msg.senderName
dirstr = "Subsidiary"
If CheckForFolder(senderName, dirstr) = False Then ' Le dossier n'existe pas
Set targetFolder = CreateSubFolder(senderName, dirstr)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(senderName)
End If
Msg.UnRead = False
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & dirstr
Resume ProgramExit
End Sub
Private Sub ServDsk_ItemAdd(ByVal up As Object)
' se déclenche lorsque nouvel élément ajouté à la boîte de réception par défaut
' (par Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim folderName As String
Dim dirstr As String
' ne rien faire pour les éléments non-Mailitems
If TypeName(up) <> "MailItem" Then GoTo ProgramExit
' déplacer l'e-mail reçu vers le dossier cible en fonction du nom de l'expéditeur
dirstr = "Service Desk"
' vérifie le sujet pour décider comment gérer le tri
Select Case True
Case InStr(Msg.Subject, "Demande") > 0
folderName = "Demandes"
Case InStr(Msg.Subject, "Incident") > 0
folderName = "Tickets"
Case InStr(Msg.Subject, "Problème") > 0
folderName = "Tickets"
Case InStr(Msg.Subject, "Ouvert") > 0
folderName = "Tickets"
Case InStr(Msg.Subject, "tâche") > 0
folderName = "Tâches"
Case InStr(Msg.Subject, "Statut") > 0
folderName = "Tickets"
Case InStr(Msg.Subject, "APPROBATION") > 0
folderName = "Demandes d'approbation OCH"
Case InStr(Msg.Subject, "Demande") > 0
folderName = "Demandes"
Case InStr(Msg.Subject, "Maintenance") > 0
folderName = "Maintenance"
Case InStr(Msg.Subject, "Alerte") > 0
folderName = "Alertes"
Case InStr(Msg.Subject, "Avis") > 0
folderName = "Alertes"
Case InStr(Msg.Subject, "Rappel") > 0
folderName = "Alertes"
End Select
If CheckForFolder(folderName, dirstr) = False Then ' Le dossier n'existe pas
Set targetFolder = CreateSubFolder(folderName, dirstr)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(dirstr).Folders(folderName)
End If
Msg.UnRead = False
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & dirstr
Resume ProgramExit
End Sub
Private Sub Vendors_ItemAdd(ByVal up As Object)
' se déclenche lorsque nouvel élément ajouté à la boîte de réception par défaut
' (per Application_Startup)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim targetFolder As Outlook.MAPIFolder
Dim senderName As String
Dim dirstr As String
Dim strDomain As String
' ne rien faire pour les éléments non-Mailitems
If TypeName(up) <> "MailItem" Then GoTo ProgramExit
Set Msg = up
' supprime le nom de domaine de l'adresse de l'expéditeur
If InStr(1, Msg.SenderEmailAddress, "@") > 0 Then
strDomain = Right(Msg.SenderEmailAddress, Len(Msg.SenderEmailAddress) - InStr(Msg.SenderEmailAddress, "@"))
End If
If CheckForFolder(senderName, strDomain) = False Then ' Le dossier n'existe pas
Set targetFolder = CreateSubFolder(senderName, strDomain)
Else
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set targetFolder = objNS.GetDefaultFolder(olFolderInbox).Folders("Vendors").Folders(strDomain)
End if
Msg.UnRead = False
Msg.Move targetFolder
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & dirstr
Resume ProgramExit
End Sub
Function CheckForFolder(strFolder As String, dirstr As String) As Boolean
' regarde le sous-dossier du dossier spécifié, renvoie TRUE si le dossier existe.
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(dirstr)
' essayer de définir une référence d'objet vers le dossier spécifié
On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0
If Not FolderToCheck Is Nothing Then
CheckForFolder = True
End If
ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
Function CreateSubFolder(strFolder As String, dirstr As String) As Outlook.MAPIFolder
' suppose que le dossier n'existe pas, donc appeler uniquement si l'appelant sait que
' le dossier n'existe pas ; renvoie un objet de dossier à l'appelant
Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(dirstr)
Set CreateSubFolder = olInbox.Folders.Add(strFolder)
ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function
