[OL-2007] Extraction de Pièces jointes [Résolu]

[shouwy]

Bonjour,

Je suis en train de développer une macro VBA pour extraire des pièces jointes des mails que je reçois.
En faite, je voudrais faire un traitement spécifique aux PDF. C'est à dire que j'extrais ces pièces jointes pour ensuite mettre le mail dans un dossier à part et ensuite m'envoyer un mail me disant le nombre de pièces jointes traités ainsi que le nombre de mails traités.
Faut-il que j'utilise Like pour vérifier sur le nom du fichier ou il y a un truc plus simple.

Je vous met mon code pour plus de visibilité de ce que je parle. Si vous voyez des erreurs ou des améliorations n'hésitez pas car je viens juste de me mettre au VBA.

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
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
95
Sub Recup_PJ()
'-------------------------------------------------------------------
' Procedure : recup_PJ()
' Auteur : Freres Thierry
' Date : 09/05/2011
' Detail : Récupération des pièces jointes de la boite de reception
'-------------------------------------------------------------------
 
' Declaration des variables
    Dim MonAppli As Outlook.Application
    Dim MonMail As Outlook.MailItem
    Dim NewMail As Outlook.MailItem
    Dim Attach As Outlook.Attachment
    Dim MonNamespace As Outlook.NameSpace
    Dim DossierRecep As Outlook.Folder
    Dim DossierTraiter As Outlook.Folder
    Dim DossierAutres As Outlook.Folder
    Dim Piece As Outlook.Attachment
    Dim NomFichier, DossierSave As String
    Dim NbPJ As Integer
    Dim NbMail As Integer
    Dim AttachIsPDF As Boolean
    Dim DateDuJour As Date
 
    ' Instanciation des Objets
    Set MonAppli = Outlook.Application
    Set MonNamespace = MonAppli.GetNamespace("MAPI")
    Set DossierRecep = MonNamespace.GetDefaultFolder(olFolderInbox)
    Set DossierTraiter = DossierRecep.Folders("Mails PDF Traiter")
    Set DossierAutres = DossierRecep.Folders("Autres Mails")
    DossierSave = "F:\SavePDF\"
    NomFichier = ""
    NbPJ = 0
    NbMail = 0
    AttachIsPDF = False
    DateDuJour = Date
 
    ' Sauvegarde les pieces jointes de la boite de reception
    ' On boucle sur chaque item (Mail) du dossier puis sur chaque pièce jointe du mail
    For Each MonMail In DossierRecep.Items
        For Each Attach In MonMail.Attachments
            ' On verifie si la piece jointe est une copie de l'original et si elle est accessible
            If Attach.Type = olByValue Then
                NomFichier = Attach.FileName
                ' On verifie si on a bien un pdf
                If NomFichier Like "*.pdf" Then
                    AttachIsPDF = True
                    NbPJ = NbPJ + 1
                    ' On sauvegarde la piece jointe dans un notre dossier avec son nom
                    Attach.SaveAsFile DossierSave & NomFichier
                End If
            End If
        Next
        ' On verifie si il y a bien eu un pdf dans le mail:
        '      - si oui on le met dans un dossier
        '      - si non on le met dans un autre dossier
        If AttachIsPDF = True Then
            MonMail.Move DossierTraiter
            NbMail = NbMail + 1
        Else
            MonMail.Move DossierAutres
        End If
        AttachIsPDF = False
    Next
 
    ' Envoi du mail avec le nombre de mail traiter ainsi que le nombre de pieces jointes
    ' On envoie un mail uniquement si il y a eu au omins 1 mail de traité
    Dim Message As String
    Message = ""
    If NbMail > 0 Then
        Set NewMail = MonAppli.CreateItem(olMailItem)
        With NewMail
            .To = ""
            .CC = ""
            .Subject = "[Collecte PDF]" & Date
            If NbMail = 1 Then
                Message = "Il y a eu " & NbMail & " Mail traité et "
                If NbPJ = 1 Then
                    Message = Message & NbPJ & " piece jointe traitée."
                Else
                    Message = Message & NbPJ & " pieces jointes traitées."
                End If
            Else
                Message = "Il y a eu " & NbMail & " Mails traités et "
                If NbPJ = 1 Then
                    Message = Message & NbPJ & " piece jointe traitée."
                Else
                    Message = Message & NbPJ & " pieces jointes traitées."
                End If
            End If
            .Body = Message
            .Send
        End With
    End If
End Sub

J'ai résolu mon problème tout seul. En utilisant Like cela marche très bien.
Attention cela plante si un mail n'est pas un mail mais MeetingItem.