Discussion :

[iperkut]

Bonjour à tous,

Je cherche à pouvoir faire une copie de certains mails dans un dossier sur le disque dur du pc.

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
 
Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
 
    Dim objFolder As Outlook.MAPIFolder
 
    Dim olMail As Outlook.MailItem
    Dim objItem As Object
    Dim strResultat As String
    Dim Categorie As String, Repertoire As String, NomExport As String, PathNomExport As String
    Dim oFSO As Scripting.FileSystemObject
 
    Set oFSO = New Scripting.FileSystemObject
 
    Categorie = "Catégorie Bleu"
 
    On Error Resume Next
 
    For Each objFolder In StartFolder.Folders
 
        Debug.Print objFolder.Name
 
        If oFSO.FolderExists("c:\mail\" & objFolder.Name) Then
            'existe
        Else
             oFSO.CreateFolder ("c:\mail\" & objFolder.Name)
        End If
 
        For Each olMail In objFolder.Items
 
            If olMail.Categories = Categorie Then
 
                NomExport = olMail.Subject & olMail.CreationTime
                Repertoire = "c:\mail\" & objFolder.Name & "\"
 
                'Ici on supprime les caractères non autorisé dans les noms de fichiers
                PathNomExport = Repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
                NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
                PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
                olMail.SaveAs PathNomExport, OlSaveAsType.olMSG
 
            End If
        Next
    Next
 
    Set objFolder = Nothing: Set olMail = Nothing
End Sub

Et j'appelle le code par :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Sub ListSubFolders()
 
    Dim OL As Outlook.Application
    Dim OLNS As Outlook.NameSpace
    Dim OLItem As Object
    Dim OLFolder As Outlook.Folders
 
    Set OL = New Outlook.Application
    Set OLNS = OL.GetNamespace("MAPI")
 
    ProcessFolder OLNS.Folders("Boîte aux lettres - VOTRENOM").Folders("Boîte de réception").Folders("2011").Folders("Autre")
 
End Sub

J'arrive donc à faire une copie des mails disposant d'un marquage 'bleu' et se trouvant dans les sous répertoires du dossier "Autre" : cf ci dessous :

|2011
->|Autre
---->| Perso
-------->| Enfant
---->| Maison
-------->| Paris
---->| Voiture
->|Client1
->| Client2

Le petit problème vient du fait que la macro ne parcourt que les dossiers : "Perso", "Maison", "Voiture" et ne "rentre" pas dans les sous-dossiers tels qu' "enfant", "Paris"

Je souhaiterai donc arriver à parcourir tous les dossiers/sous-dossiers du dossier "Autre"

Merci d'avance pour votre aide

[carden752]

Bonjour,

Un appel récursif me parait la meilleur solution. La modification est en rouge, je te laisse tester.

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
   For Each objFolder In StartFolder.Folders
 
        Debug.Print objFolder.Name
 
        If oFSO.FolderExists("c:\mail\" & objFolder.Name) Then
            'existe
        Else
             oFSO.CreateFolder ("c:\mail\" & objFolder.Name)
        End If
 
        For Each olMail In objFolder.Items
 
            If olMail.Categories = Categorie Then
 
                NomExport = olMail.Subject & olMail.CreationTime
                Repertoire = "c:\mail\" & objFolder.Name & "\"
 
                'Ici on supprime les caractères non autorisé dans les noms de fichiers
                PathNomExport = Repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
                NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
 
                PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
                olMail.SaveAs PathNomExport, OlSaveAsType.olMSG
 
            End If
        Next

If objfolder.folders.count<>0 Then
ProcessFolder objfolder
End if

    Next

[iperkut]

Bonjour,

En effet cela semble être la bonne solution cependant il y a maintenant un petit problème.

L'appel récursif se passe bien, et la macro parcourt bien tous les dossiers sauf que du coup, le code que j'ai écrit :

Code :

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

1
2
3
4
5
6
7
 
        Chemin = "c:\mail\" & objFolder.Name & "\"
        If oFSO.FolderExists(Chemin) Then
            'existe
        Else
            oFSO.CreateFolder (Chemin)
        End If

Ne marche plus pour l'appel récursif ex :
|2011
->|Autre
---->| Perso
-------->| Enfant
---->| Maison
-------->| Paris
---->| Voiture
->|Client1
->| Client2

Quand la marco fait le dossier Enfant, le sub se fait donc rappeler et un dossier "Enfant" est créer au même niveau Perso ou Maison au lieu d'être créer dans "Perso/Enfant"

J'ai donc pensé à faire quelque chose du genre :

Code :

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

1
2
3
4
5
6
7
 
        Chemin = "c:\mail\" & objFolder.Parent & "\" & objFolder.Name & "\"
        If oFSO.FolderExists(Chemin) Then
            'existe
        Else
            oFSO.CreateFolder (Chemin)
        End If

Sauf que cela ne marche pas..

Merci d'avance

[carden752]

Bonjour,

Il faut tester l'existence du dossier père avant de tester celle du fils et si besoin créer le dossier père avant celui du fils.
La fonction CreateFolder ne fonctionne que sur un seul niveau. Il crée pas tous les dossiers parents s'il n'existent pas.