Suppression des dossiers vides dans Outllook après archivage automatique VBA

[amanteau]

Salut à tous,

Je viens faire appel à vos lumières.
Voici mon souci: Je souhaiterais utiliser un script vba qui permettrait la suppression des dossiers vides dans outlook. Comme vous pouvez peut-être le savoir, au cours d'un archivage automatique Outlook ne fait que déplacer dans le dossier d'archivage l'ensemble des mails sélectionnés (par des règles précises), et s'il est nécessaire, il créé au passage de nouveaux dossiers/sous-dossiers si ces mails étaient contenus dans des dossiers/sous-dossiers. Jusque là tout va bien, mais le hic, c'est qu'après l'archivage, il me reste un nombre conséquent de dossiers/sous-dossiers vides dans celui d'origine. J'ai pu trouver un code vba qui permettrait d'effectuer cette "purge", seulement ce dernier ne semble pas optimisé et efficace lorsqu'il y a plusieurs niveaux de sous-dossiers. Ne connaissant pas le VBA, ou du moins très peu, je fais donc appel à vos lumière afin de savoir ce qui pourrait être apporté au code d'origine.

Code :

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
 
 
Public Sub DeletindEmtpyFolder()
Dim mytoplvl As Folders
 
    Set mytoplvl = Outlook.GetNamespace("MAPI").PickFolder.Folders
    FolderPurge mytoplvl
 
End Sub
 
 
Public Sub FolderPurge(mytoplvl As Folders)
Dim myFldr As Folder 'Declare sub folder objects
 
If mytoplvl.Count <> 0 Then
 
    Debug.Print "Analyzing: " & mytoplvl.GetFirst.Name
 
    For Each myFldr In mytoplvl 'Sweep through each folder under the inbox
 
        If myFldr.Items.Count < 1 Then 'If the folder is empty check for subfolders
            If myFldr.Folders.Count < 1 Then 'If the folder contains not sub folders confirm deletion
                Debug.Print myFldr.Name & " contains no items, and will be deleted."
                myFldr.Delete 'Delete the folder
            Else 'Folder contains sub folders so confirm deletion
                FolderPurge myFldr.Folders
            End If
 
        Else 'Folder contains items so leave alone.
            Debug.Print myFldr.Name & " contains items so would be left alone"
        End If
 
    Next myFldr
 
Else
    Debug.Print "The folder does not contain any sub folders"
End If
 
End Sub

Je ne sais pas si je dois mettre le lien de ma source, mais je pourrais l'ajouter à la demande d'un admin.

Merci à vous.

[kiki29]

Salut, j'ai ceci mais il faudra l'adapter à ton contexte car je n'utilise pas OutLook, espérant t'être utile

Code :

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
Option Explicit
 
Sub SelDossier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Suppression Dossiers / Sous Dossiers vides"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            DeleteDossiersVides .SelectedItems(1)
        End If
    End With
End Sub
 
Private Sub DeleteDossiersVides(sDossier As String)
Dim FSO As Object
Dim oDossier As Object
Dim oSousDossier As Object
Dim NbDossiers As Long
Dim NbSousDossiers As Long
Dim sChemins() As String
 
    DoEvents
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If Not FSO.FolderExists(sDossier) Then Exit Sub
 
    Set oDossier = FSO.GetFolder(sDossier)
 
    If oDossier.SubFolders.Count > 0 Then
        NbDossiers = 1
        ReDim sChemins(1 To oDossier.SubFolders.Count)
        For Each oSousDossier In oDossier.SubFolders
            sChemins(NbDossiers) = oSousDossier.Path
            NbDossiers = NbDossiers + 1
        Next oSousDossier
 
        NbSousDossiers = 1
        Do While NbSousDossiers < NbDossiers
            DeleteDossiersVides sChemins(NbSousDossiers)
            NbSousDossiers = NbSousDossiers + 1
        Loop
    End If
 
    If oDossier.Files.Count = 0 And oDossier.SubFolders.Count = 0 Then
        oDossier.Delete
    End If
 
    Set oDossier = Nothing
    Set FSO = Nothing
End Sub

[amanteau]

Ok merci, je regarde ça de suite et vois si cela peut s'adapter à Outlook.
Merci pour l'aide.

[carden752]

Bonjour,

Plutôt que tester la valeur <1, je testerai =0.
Ensuite, il doit pouvoir être combiner les deux paramètres avec un AND.
Le Purge ne sera effectif que s'il contient des sous-dossiers sinon passage dans le Esle pour

Code :

If mytoplvl.Count <> 0 Then

S'il passe dans le Else alors il n'y avait pas de sous dossiers donc il y avait des items.


Quelque chose de ce style à tester

Code :

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
Public Sub FolderPurge(mytoplvl As Folders)
Dim myFldr As Folder 'Declare sub folder objects
 
If mytoplvl.Count <> 0 Then
 
    Debug.Print "Analyzing: " & mytoplvl.GetFirst.Name
 
    For Each myFldr In mytoplvl 'Sweep through each folder under the inbox
 
        If myFldr.Items.Count =0 and myFldr.Folders.Count=0  Then 'If the folder contains not sub folders and no items confirm deletion
                Debug.Print myFldr.Name & " contains no items, and will be deleted."
                myFldr.Delete 'Delete the folder
            Else 'Folder contains sub folders so confirm deletion
                FolderPurge myFldr.Folders
            End If
 
    Next myFldr
 
Else
    Debug.Print "The folder does not contain any sub folders" and Folder contains items so leave alone.
            Debug.Print myFldr.Name & " contains items so would be left alone"
 
End If
 
End Sub

[amanteau]

Merci pour ce retour. L'idée de mettre à 0 au lieu de <1 est bonne.
Toutefois, cela ne colle pas encore, je creuse encore mes recherches. Merci