Discussion :

[SUKINET]

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

[joe.levrai]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Oliv-]

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

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

[joe.levrai]

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 )

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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$")