Extraire PJ outlook

Le 24/08/2017 à 13:49

Bonjour à tous,

J'aimerai vous solliciter afin de comprendre le code suivant et de l'adapter à mes besoins.

Une liste des choses que j'aimerai faire :

  • chercher seulement dans les mails récents (moins d'un mois);
  • tenir compte des mails qui contiennent seulement un mot clef (nom du dossier);
  • extraire tous les fichiers .pdf .xls .xlsx.

J'ai trouvé ce code sur le forum, mais je n'ai pas réussi à l'adapter même juste pour récupérer une PJ dont j'ai rentrer le nom exact. La macro tourne en boucle sans jamais s'arrêter :/.

Merci d'avance pour votre contribution.

Sub SaveAttachment()

'Declaration
   Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim i As Integer
    Dim nomFichier As String, extFichier As String

    'Boîte de dialogue simple pour le chemin de sauvegarde
   myOrt = InputBox("Destination", "Save Attachments", "C:\PJ\")

    On Error Resume Next

    'Actions sur les objets sélectionnés
   Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection

    'boucle
   For Each myItem In myOlSel
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then

            'for all attachments do...
           For i = 1 To myAttachments.Count

                'teste le mail de l'émetteur
               Select Case myItem.SenderEmailAddress
                Case ".....@societe-A.com"
                    extFichier = "xls"
                    nomFichier = IIf(LCase(Right(myAttachments(i).Filename, Len(extFichier))) = LCase(extFichier), "synthese." & extFichier, "")
                Case ".....@société-B.com"
                    extFichier = "xls"
                    nomFichier = IIf(LCase(Right(myAttachments(i).Filename, Len(extFichier))) = LCase(extFichier), "prix de vente." & extFichier, "")
                Case "....@shp.ie.com"
                    extFichier = "xlsx"
                    nomFichier = IIf(LCase(Right(myAttachments(i).Filename, Len(extFichier))) = LCase(extFichier), "IE - Tréso." & extFichier, "")
                End Select

                'si l'extension de la pièce jointe est connue et correspond au fichier de sortie, on effectue la sauvegarde
               If nomFichier <> "" Then
                    'save them to destination
                   myAttachments(i).SaveAsFile myOrt & _
                                                myAttachments(i).DisplayName
                    myAttachments(i).SaveAsFile myOrt & _
                                                nomFichier
                    myItem.Body = myItem.Body & _
                                  "File: " & myOrt & _
                                  myAttachments(i).DisplayName & vbCrLf
                End If

            Next i

        End If

    Next

    Set myItems = Nothing
    Set myItem = Nothing
    Set myAttachments = Nothing
    Set myAttachment = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing

End Sub

https://forum.excel-pratique.com/excel/macro-enregistrer-piece-jointe-outlook-t55473.html

Le 24/08/2017 à 14:03

Bonjour,

Il n'est pas nécessaire de passer par l'explorateur d'Outlook. Il suffit de définir le compte de messagerie où se trouve les mails à examiner. Soit c'est le compte par défaut d'Outlook, soit c'est un autre. Si c'est un autre, alors son identification est nécessaire.

Le 24/08/2017 à 14:16
thev a écrit :

Bonjour,

Il n'est pas nécessaire de passer par l'explorateur d'Outlook. Il suffit de définir le compte de messagerie où se trouve les mails à examiner. Soit c'est le compte par défaut d'Outlook, soit c'est un autre. Si c'est un autre, alors son identification est nécessaire.

Euh ... Merci. J'imagine que c'est une préconisation efficace mais le code n'est pas de moi et donc je ne vois pas du tout ou tu veux en venir.

Je suis novice ++ en VBA

Par exemple c'quoi l'instruction

Case

?

Le 24/08/2017 à 16:35

Bonjour,

Je pense que le code choisi est mal adapté à votre besoin.

En supposant que vos mails se trouvent dans la boîte de réception de votre compte de messagerie par défaut dans Outlook, ci-dessous code pour récupérer les noms de fichier de vos mais de moins d'1 mois :

Sub récup_PJ()
    Dim olApp As New Outlook.Application
    Dim inbox_défaut As Folder, mail As Object, pj As Object
    Dim nom_fichier As String

    'balayage mails boîte de réception compte messagerie par défaut
    Set inbox_défaut = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In inbox_défaut.Items
        If mail.CreationTime > DateAdd("m", -1, Date) Then
            For Each pj In mail.Attachments
                nom_fichier = pj.Filename
            Next pj
        End If
    Next mail

End Sub

Instruction case : voir ce lien https://msdn.microsoft.com/fr-fr/library/2h66e7a8(v=vs.90)

Le 24/08/2017 à 16:45

Salut !

Ca marche super bien j'ai eu la bonne idée de mettre une msgbox pour chaque PJ mddr j'ai eu beaucoup de clique à faire.

Comment puis-je allez chercher les pièces jointes du dernier mail d'une adresse renseigné au préalable ?

Aussi, j'aimerai transférer ces PJ dans un fichier défini.

Je te remercie beaucoup de ton aide, ton code est exactement ce que je recherche court et simple à comprendre. Je me pencherai un peu plus dessus demain.

J'espère ne pas trop t'en demandé !

Cdlt,

Le 24/08/2017 à 17:10
VH_AE a écrit :

Comment puis-je allez chercher les pièces jointes du dernier mail d'une adresse renseigné au préalable ?

ci-dessous exemple de code

Sub récup_PJ()
    Dim olApp As New Outlook.Application
    Dim inbox_défaut As Folder, mail As Object, dernier_mail As Object, pj As Object
    Dim adresse As String, nom_fichier As String, dernière_date As Date

    'balayage mails boîte de réception compte messagerie par défaut
    adresse = "xxxxx@domaine.fr"
    Set inbox_défaut = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In inbox_défaut.Items
        On Error Resume Next
        If mail.SenderEmailAddress = adresse Then
            If mail.CreationTime > dernière_date Then dernière_date = mail.CreationTime: Set dernier_mail = mail
        End If
    Next mail

    'balayage pièces jointes dernier mail
    For Each pj In dernier_mail.Attachments
        nom_fichier = pj.Filename
    Next pj
End Sub
Le 25/08/2017 à 10:21

Bonjour,

Tu m'a beaucoup avancé (tu m'a même déposé presque à la fin).

J'ai réussi à m'imprégner du code et à faire quelque modification à ma convenance, seulement j'ai de nouveaux problèmes quant aux conditions de sélection du mail.

Voici,ce que j'ai tenté de faire au niveau des lignes surlignées dans le code plus bas :

  • le corps et l'objet du mail doit contenir le nom du dossier;
  • le nombre de pièces jointe (sans prendre en compte les images) doit être supérieures à 0;***

*** aussi, s'il est possible d'ajouter une condition de format (.pdf, xls, xlsx).

Aussi, je ne demande pas à reprendre l'ensemble du code mais m'indiquer les modifications et les instructions à inscrire.

Merci beaucoup !

Sub récup_PJ()
    Dim olApp As New Outlook.Application
    Dim inbox_défaut As Folder, mail As Object, dernier_mail As Object, pj As Object
    Dim adresse As String, nom_fichier As String, dest As String, dernière_date As Date

    dest = "C:\Users\AAl\Desktop\PJ\"

    'balayage mails boîte de réception compte messagerie par défaut
   adresse = "xxxx@societe.com"
    Set inbox_défaut = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In inbox_défaut.Items
    On Error Resume Next
    If mail.SenderEmailAddress = adresse Then
        If InStr(1, mail.Body, "NOMDOSSIER") > 0 And mail.Attachments.CountIf(InStr(0, mail.Attachments.Filename, "NOMDOSSIER") > 1) > 0 Then
        Set dernier_mail = mail
        'pour visualiser le résultat du code sans extraire n'importe quoi
        MsgBox dernier_mail.Subject & dernier_mail.Body
        Exit Sub
        End If

            'If mail.CreationTime > dernière_date Then dernière_date = mail.CreationTime: Set dernier_mail = mail
        End If
    Next mail

    'balayage pièces jointes dernier mail
   For Each pj In dernier_mail.Attachments
        nom_fichier = pj.Filename
        If InStr(1, nom_fichier, "image") = 0 Then
        pj.SaveAsFile dest & nom_fichier
        End If
    Next pj
End Sub
Le 25/08/2017 à 12:34

Bonjour,

voici ce qui pourrait être fait :

Sub récup_PJ()
    Dim olApp As New Outlook.Application
    Dim inbox_défaut As Folder, mail As Object, dernier_mail As Object, pj As Object
    Dim adresse As String, nom_fichier As String, extension As String
    Dim mails_retenus As New Collection
    Dim Extensions()

    'balayage mails boîte de réception compte messagerie par défaut
    adresse = "xxxx@societe.com"
    Set inbox_défaut = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In inbox_défaut.Items
        On Error Resume Next
        If mail.SenderEmailAddress = adresse Then
                If mail.Body Like "*NOMDOSSIER*" _
                And mail.Attachments.Count > 0 Then
                    mails_retenus.Add mail
                    'pour visualiser le résultat du code sans extraire n'importe quoi
                    'MsgBox mail.Subject & mail.Body
                End If
         End If
    Next mail

    'balayage pièces jointes mails retenus
    Extensions = Array("pdf", "xls", "xlsm")
    For Each mail In mails_retenus
        For Each pj In mail.Attachments
            extension = Right(pj.Filename, Len(pj.Filename) - InStrRev(pj.Filename, "."))
            If UBound(Filter(Extensions, extension)) > -1 Then nom_fichier = pj.Filename
        Next pj
    Next mail
End Sub
Le 25/08/2017 à 13:50

Salut,

Merci beaucoup sa fonctionne. J'aurai une dernière requête : comment puis-je faire apparaître les noms des PJ dans une msgbox afin de confirmer qu'il s'agit bien de ce mail ?

J'ai pensé à afficher le corps du mail mais difficilement séparable de la signature etc.. sa donne une msgbox super lourde.

Aussi, quand j'affiche la première PJ sa prend en compte les images qui y sont rattachés.

Cdlt,

Sub récup_PJ()
    Dim olApp As New Outlook.Application
    Dim inbox_défaut As Folder, mail As Object, dernier_mail As Object, pj As Object
    Dim adresse As String, nom_fichier As String, extension As String, dest As String
    Dim mails_retenus As New Collection
    Dim Extensions()

    dest = "C:\Users\A\Desktop\Outils\PJ\"

    'balayage mails boîte de réception compte messagerie par défaut
   adresse = "***r@societecom"
    Set inbox_défaut = olApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    For Each mail In inbox_défaut.Items
        On Error Resume Next
        If mail.SenderEmailAddress = adresse Then
                If mail.Body Like "*NOMDOSSIER*" _
                And mail.Attachments.Count > 0 Then
                    mails_retenus.Add mail
                    'pour visualiser le résultat du code sans extraire n'importe quoi
                   MsgBox mail.Subject & mail.Attachments(1).Filename
                   Exit Sub
               End If
         End If
    Next mail

    'balayage pièces jointes mails retenus
   Extensions = Array("pdf", "xls", "xlsm", "7z", "xlsx")
    For Each mail In mails_retenus
        For Each pj In mail.Attachments
            extension = Right(pj.Filename, Len(pj.Filename) - InStrRev(pj.Filename, "."))
            If UBound(Filter(Extensions, extension)) > -1 Then nom_fichier = pj.Filename
            pj.SaveAsFile dest & nom_fichier
        Next pj
    Next mail

Je te met le fichier en PJ.

N.B : En fait, on travail en tant que consultant pour des société. On attend qu'il nous envoie des pièces afin de procéder à une analyse. Je voudrais ajouté ce code à celui de la création automatiser des dossiers. Et je ne voudrais pas récupérer des PJ inutiles ou des les mauvaises PJ.

Edit : Je tente à améliorer le code de mon côté, et en fait le "mail.Attachments.Count > 0 " n'est pas pertinent car selon le code VBA les images attachés au mail sont des PJ. J'aimerai qu'elle ne soit pas pris en compte dans le calcul, j'ai essayer avec "countIf" mais sa ne me donne rien. Je réédit si j'ai trouvé quelque chose.

223extract.xlsm (14.79 Ko)
Le 25/08/2017 à 18:21

Bonsoir,

pour que "pj.SaveAsFile dest & nom_fichier" soit conditionné par le "if" , il faut ajouter ":" pour séquencer les instructions sur la même ligne.

If UBound(Filter(Extensions, extension)) > -1 Then nom_fichier = pj.Filename: pj.SaveAsFile dest & nom_fichier

ou

            If UBound(Filter(Extensions, extension)) > -1 Then
                nom_fichier = pj.Filename
                pj.SaveAsFile dest & nom_fichier
            End If
VH_AE a écrit :

le "mail.Attachments.Count > 0 " n'est pas pertinent car selon le code VBA les images attachés au mail sont des PJ

C'est vrai que les images attachés au mail sont des PJ mais le "mail.Attachments.Count > 0 " peut être pertinent pour éliminer des mails qui n'en ont pas, comme par exemple les confirmations de lecture ou des réponses basiques.

Pour éliminer les images, pas d'autre moyen que de balayer l'ensemble des pièces jointes.

Le "CountIF" est une fonction et ne peut donc être utilisée qu'avec l'objet Application : Application.CountIF

Le 28/08/2017 à 09:15

Salut,

Merci pour ces explications, j'ai tu m'as déjà bien assez aidé. La macro est largement suffisante et je vais me débrouiller pour la mettre en place.

Je met le sujet en résolu. Merci à toi !

Cdlt,

Rechercher des sujets similaires à "extraire outlook"