Discussion :

[steph77]

Bonjour le forum,
j'ai bien trouvé les lignes de code qui permettent de déplacer un email sélectionné de la boite de réception vers un dossier "Test" de cette même boite de réception, mais je sèche pour déplacer mon email vers un sous dossier du genre :
Boite de réception
-France
-Allemagne
-Italie
----Represantant
----Client
--------PJ12-124
--------PJ12-125

Code :

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

1
2
3
4
5
6
7
8
 
Set MonApply = Outlook.Application
Set MonNSpace = MonApply.GetNamespace("MAPI")   
Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox) 
Set MyItemObj = Fldossier.Items(myItem.Subject)
Set Mainbox = MonNSpace.GetDefaultFolder(olFolderInbox)
Set MonDestFolder = Mainbox.Folders("PJ12-125")
MyItemObj.Move MonDestFolder

[steph77]

J'ai un début de piste avec :

Code :

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

1
2
 
Set MonDestFolder = Mainbox.folders("Italie").folders("Client").folders("PJ12-125")

Qui déplace mon email ayant pour objet "PJ12-125" vers le bon dossier.

Maintenant c'est d'automatiser la manipulation qui me pose problème.
En effet, à la réception de mon email, j'ai une routine qui s’exécute si dans l'objet j'ai le mot clef "PJ" (PJxxxxx), celui-ci contrôle qu'un dossier portant le même nom existe si ce n'est pas le cas, on informe l'utilisateur, sinon, on classe l'email dans ce dossier.
Par la procédure précédente, j'ai le nom complet qui remonte dans une variable CheminComplet = \\dossier untel\Italie\Client\Pj12-125.
Il me reste à trouver comment automatiser en fonction des différents sous-répertoires.
Quelqu'un aurai t'il une piste?

[steph77]

Finalement j'ai trouvé, pour ceux que ça intéresse je post le code:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
Dim DossierCible As Outlook.folder
 
'Adresse du mail à déplacer
Set MyItemObj = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items(myItem.Subject)                     
 
'Avec GetFolder j'envoi dans une variable l'adresse du dossier ou le mail doit être déposé
Set DossierCible = GetFolder(SsDossier)
 
'Je déplace mon email vers le dossier               
MyItemObj.Move DossierCible

Le chemin du dossier cible "SsDossier" doit être testé avant afin d'éviter un plantage.
Ci-joint le code complet pour tester la présence du dossier et remonter le chemin complet.

Code :

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
93
94
 
Private Sub Application_ItemLoad(ByVal Item As Object) '//Lorsqu'on clic sur un objet
'//Declaration des variables//
Dim TrvPj As String
Dim TrvTiret As String
Dim MyItemObj
Dim MonDosDest
 
If Not Item.Class = olMail Then Exit Sub 'Si l'objet n'est pas un Email, sortir de la boucle
 
       Set myItem = ActiveExplorer.Selection.Item(1)    'La variable MyItem prend la valeur de l'objet du mail
 
        If myItem.Subject Like "*PJ*" Then                  'Si l'objet contient les lettre PJ lancer l'analyse
 
            '****Extraire le code projet de l'objet****
            TrvPj = InStr(myItem, "PJ")                  'Renvoi la position de PJ dans l'objet
            TrvTiret = InStr(TrvPj, myItem, "-")     'Renvoi la position du tiret dans l'objet
            If TrvTiret = 0 Then MsgBox "The dash is missing": Exit Sub 'Si le Tiret est manquant : Sortir de la boucle et informer l'utilisateur
            PjName = Mid(myItem, TrvPj, 8)         'Renvoi le nom du projet pour le traitement dans le module de recherche
            '**********************************
            SsRacine = "": SsDossier = "": Compteur = 0           'Initialise les variables
 
            Call EnumerateFoldersInStores           'Appel de la sous procédure
 
            If boolverif = False And Compteur = 1 Then
 
                Set MyItemObj = Outlook.Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Items(myItem.Subject)                     'mail a deplacer
 
                    Dim DossierCible As Outlook.folder
                    Set DossierCible = GetFolder(SsDossier)
 
                MyItemObj.Move DossierCible
 
            End If
 
        End If
 
End Sub
 
 
Sub EnumerateFoldersInStores()
    Dim olApp As New Outlook.Application
    Dim colStores As Outlook.Stores
    Dim oStore As Outlook.Store
    Dim oRoot As Outlook.folder
 
    boolverif = True
 
    On Error Resume Next
    Set colStores = olApp.Session.Stores
 
    For Each oStore In colStores
 
        Set oRoot = oStore.GetRootFolder
        Debug.Print (oRoot.FolderPath) 'Affiche la racine du répertoire
        Racine = oRoot                           'Mémorise la racine du répertoire
        EnumerateFolders oRoot           'Appel de la sous procédure
 
     Next
 
   If Compteur > 1 Then
        MsgBox " You have many folder with same name"
   End If
 
   If boolverif = True Then
        MsgBox "You must created folder before archive it"
   End If
 
End Sub
 
 
Private Sub EnumerateFolders(ByVal oFolder As Outlook.folder)
    Dim folders As Outlook.folders
    Dim folder As Outlook.folder
    Dim foldercount As Integer
 
    On Error Resume Next
    Set folders = oFolder.folders
    foldercount = folders.Count
 
    If foldercount Then
 
        For Each folder In folders
            Debug.Print (folder.FolderPath) 'Affiche le chemin du contenu du répertoire (sous-dossier)
            EnumerateFolders folder
            If folder Like PjName Then
               boolverif = False
               Compteur = Compteur + 1
               SsDossier = folder.FolderPath
               SsRacine = Racine
            End If
        Next
 
   End If

[yaazedine]

Bonjour steph,
Je suis intéresser par ce sujet puisque j'ai le même problème que toi,j'ai essayer mais j'arrive pas a enregistrer mon mail sur un dossier spécifique qui porte le même nom de l'objet d'un mail reçu !!
Mercii

[steph77]

bonjour,
et avec le code que j'ai posté ça ne marche pas?

[yaazedine]

Bonjour,

J'ai tester plusieurs fois mais a chaque fois j'ai le MsgBox "You must created folder before archive it" ,mm si j'ai déjà créer le dossier !!

[Oliv-]

Salut
Ton pb n est sans doute pas identique