Deplacer un mail dans un sous dossier d'apres son objet

Bonjour,

J'ai adapté un code (merci DOLPHY 35) pour enregistrer un mail dans un sous dossier en fonction de l'objet d'un mail.

Private Sub Application_NewMail()
'Private Sub Application_NewMail(ByVal EntryIDCollection As String)

'Déclarations

Dim Exp As Explorer
Dim Sel As Selection
Dim Itm As MailItem

Dim dossier As MAPIFolder
Dim myNewFolder As MAPIFolder

Dim myNamespace As Outlook.NameSpace
Dim myInbox As Outlook.MAPIFolder

Dim ObjItem As Outlook.MailItem

Dim MonApp As Outlook.Application
Dim MonMail As Object
Dim MonNameSpace As Outlook.NameSpace
Dim MonDossier As Outlook.Folder

'Instance des variables
Set MonApp = Outlook.Application
Set MonNameSpace = MonApp.GetNamespace("MAPI")
Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
'Set MonMail = MonApp.GetItemFromID(EntryIDCollection)
Set MonMail = Application.Session.GetItemFromID(EntryIDCollection)

If MonMail.SenderEmailAddress = "recrutement@dalta-com" Then

On Error Resume Next
Set MonApp = GetObject(, "Outlook.Application")
On Error GoTo 0

If MonApp Is Nothing Then
Set MonApp = CreateObject("Outlook.Application")
End If

Set Exp = ActiveExplorer
Set Sel = Exp.Selection

Set MonNameSpace = MonApp.GetNamespace("MAPI")

For Each Itm In Sel
Candidats$ = Mid(Itm.Subject, 28)
Candidat_Dossier$ = Mid(Itm.Subject, 28, 1)
Canditat_Test$ = Mid(Itm.Subject, 1, 21)
CP$ = Mid(Itm.Subject, 22, 5)
Candidats_CP$ = Candidats$ & " (" & CP$ & ")"

Itm.Save

If Canditat_Test$ = "Nouvelle candidature " Then
Set MonNameSpace = MonApp.GetNamespace("MAPI")
Set dossier = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$)
Set NewFolder = dossier.Folders.Add(Candidats_CP$) 'DALTA_Candidatures
Candidat_Dossier_Complet$ = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders(Candidats_CP$)
' If CheckForFolder(Folder) = False Then 'dossier n'existe pas
' Set myNewFolder = CreateSubFolder(Folder) 'creation du sous dossier
' End If

'Set myNameSpace = objOutlook.GetNamespace("MAPI")
Set myInbox = MonNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders(Candidats_CP$)

Myentryid = Itm.EntryID
Set Itm = Itm.Move(myDestFolder)

'Set itm2 = itm2.Move(MonNameSpace.Folders("DALTA_Candidatures").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders(Candidat$))

End If

Next Itm

Set Itm = Nothing
Set Sel = Nothing
Set Exp = Nothing

End If

End Sub

je l'ai placé dans "Application" / "NewMail"
mais le code se plnte à cette instruction
Set MonMail = Application.Session.GetItemFromID(EntryIDCollection)

et je ne sais pas comment résoudre cette erreur.

C'est pourquoi je fais appel à votre aide...

Si quelqu'un me m'indiquer comment tester l'existance du dossier avant de deplacer (avec creation sous dossier si besoin)
Set myDestFolder = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders(Candidats_CP$)

MERCI D'AVANCE

Bonjour,

on peut éventuellement balayer la liste des sous dossiers, si on ne le trouve pas, on le crée

exemple, si le sous dossier recherché est "Candidats_CP$"

teste si c'est ok, je ne l'ai pas fais

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14

Dim Dossier As Outlook.MAPIFolder Dim Existe As Boolean   For Each Dossier In MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders If Dossier.Name = "Candidats_CP$" Then Set myDestFolder = Dossier Existe = True Exit For End If Next Dossier   If Existe = False Then Set myDestFolder = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$).Folders.Add("Candidats_CP$") End If

---

Bonjour,
tu peux t'inspirer des codes de cette discussion

http://www.developpez.net/forums/d15...s-sauvegarder/

Bonjour,

je continue d'alimenter le moulin
on peut éviter de parcourir l'ensemble des sous-dossiers en utilisant à son profit une erreur VBA
(bien pratique quand on a des procédures qui bouclent sur des centaines de boites mails et des millions de dossiers ... je parle en connaissance de cause :aie:)

Code:

---

1 2 3 4 5 6 7 8 9 10

Dim MonRepertoire As Outlook.MAPIFolder   Set MonRepertoire = MonNameSpace.Folders("HOLDING_Candidatures").Folders("TRAVAUX_CANDIDATS").Folders("DALTA_Candidatures").Folders(Candidat_Dossier$)   On Error Resume Next Set myDestFolder = MonRepertoire.Folders("Candidats_CP$") On Error Goto 0   'le dossier n'existe pas, il faut le créer If myDestFolder Is Nothing Then Set myDestFolder = MonRepertoire.Folders.Add("Candidats_CP$")

---