Discussion :

[teapote]

Bonjour a tous !

Dans le cadre du boulot, j'aimerais extraire les pieces jointes, au format ".xls*", d'un dossier Outlook nommé "test".

Si ces mails sont munis d'une ou plusieurs pièce jointe (pas toujours le cas), j'aimerais deplacer le mail vers un dossier "test2".

A la fin il ne devrait plus que me rester les mails sans pièces jointes dans "test" et les mails avec pièces jointes dans "test2".

Deux problèmes :

• A quel moment du code faut-il déplacer le mail ? (Ici le mail est déplacé qu'il soit muni d'un PJ ou non)
• Le code fonctionne mais s'arrête toujours au milieu, sans message d'erreur (s'il y a 50 mails il en déplace 25, je relance la macro il en bouge 12 autres, puis 6...). C'est incompréhensible, je me prend la tête dessus !

Voici le code que j'ai pu obtenir en aller chercher des petits bouts sur plusieurs forums :

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
Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
 
Dim x As Integer
 
    'La boite de réception, la boite des éléments supprimés et tous leurs
    'sous dossiers sont pris en compte.
Sub ExportePiecesJointes()
    Dim Ol As New Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Dossier As Outlook.MAPIFolder
 
    Set Ns = Ol.GetNamespace("MAPI")
    Set Dossier = Ns.Folders(1)
 
    SearchFolders Dossier
    x = 0
End Sub
 
 
Private Sub SearchFolders(ByVal fld As Outlook.MAPIFolder)
 
 
Dim y As Integer
Dim olmail As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
Dim myNameSpace As Outlook.NameSpace
Dim myDestFolder As Outlook.MAPIFolder
Dim myInbox As Outlook.MAPIFolder
Dim myOlApp As New Outlook.Application
 
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("test2")
 
For Each SousDossier In fld.Folders
    If SousDossier.DefaultItemType = 0 And SousDossier.Name = "Test" Then
        For Each olmail In SousDossier.Items
            If Not olmail.Attachments.Count = 0 Then
                For y = 1 To olmail.Attachments.Count
                     Set pceJointe = olmail.Attachments(y)
                        If Right(pceJointe.FileName, 3) = "xls" Or Right(pceJointe.FileName, 4) = "xlsx" Then
                        x = x + 1
                        pceJointe.SaveAsFile "Chemin d'accès"                        End If
                        olmail.Move myDestFolder
                     Set pceJointe = Nothing
                Next y
            End If
        Next olmail
    End If
    SearchFolders SousDossier
 
Next SousDossier
End Sub

Merci à celui qui pourra m'aider !

[Golonne]

Bonjour,

Je crois que ton problème vient du fait que tu retires des objets d'une énumération. Essaye plutôt de boucler à l'envers avec

Code :

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

1
2
3
For i = SousDossier.Items.Count to 1 step -1
...
Next i

plutôt que ton For Each... Next et ça devrait le faire.

Guillaume