Outlook extraire pièce jointe depuis un mail lui-même en pièce jointe

[bouhamed mohamed elmahdi]

Bonjour,

Je suis un débutant sur le VBA et je rencontre un petit souci au niveau d'un code que j'utilise au niveau d'Outlook et j'aurais bien besoin de vos lumières si possible.
Problématique: je reçoit un email (de la part de mon responsable hiérarchique) et dans lequel il m'envoi en piece jointe des emails qui, eux-mêmes, contiennent des pièces jointes (fichier .csv) avec lesquels je doit bosser.
Mon problème est qu'avec le code VBA ci-dessous, j'arrive à extraire les pièces jointes dans un répertoire sur mon disque dur, mais ce sont seulement les emails qui sont sauvegardés et non pas les fichiers .cvs
Auriez-vous SVP des propositions pour modifier mon code afin de pouvoir extraire les pièces jointes .csv qui sont dans les emails, eux-mêmes en pièce jointe ?

Ci-dessous une capture du mail pour mieux comprendre la situation.
https://drive.google.com/open?id=0B4e6F1NbID1TQk1QTkxOTzExUlE

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
For Each SousDossier In fld.Folders
'.Item("Nom_Du_Dossier").Items
'MsgBox SousDossier.Name
    If SousDossier.DefaultItemType = 0 And SousDossier.Name = "extraction ventes" 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)
                     pceJointe.SaveAsFile "C:\PJ\" & pceJointe
                     Set pceJointe = Nothing
                Next y
            End If
        Next OLmail
    End If
    SearchFolders SousDossier
Next SousDossier
End Sub

 

[Morning]

Bonjour ,

J'ai également le même problème , avez vous trouvé une solution

 

[mromain]

Bonjour Morning et bienvenue sur le forum,
Bonjour le forum,

L'idée consiste à enregistrer le mail en PJ sur le disque, et ensuite l'ouvrir pour traiter ses pièces jointes.
Voici un essai :

Sub Test()
Dim l_o_mail As Outlook.mailItem
Dim l_o_mailPj As Outlook.mailItem
Dim l_s_pathMail As String
Dim l_o_attachment As Outlook.Attachment
    
    'récupérer le mail ayant comme PJ le mail contenant la PJ à récupérer
    Set l_o_mail = ...
    
    'récupérer la PJ du mail (donc l'autre mail)
    Set l_o_attachment = l_o_mail.Attachments(1)
    
    'enregistrer le mail (de la PJ) dans le dossier TMP de l'utilisateur
    l_s_pathMail = Environ("USERPROFILE") & "\AppData\Local\Temp\" & l_o_attachment.FileName    'définir l'emplacement du fichier
    l_o_attachment.SaveAsFile l_s_pathMail                                                      'enregistrer la PJ
    
    'ouvrir de mail
    Set l_o_mailPj = Application.Session.OpenSharedItem(l_s_pathMail)
    
    'traiter sa/ses PJs
    For Each l_o_attachment In l_o_mailPj.Attachments
        MsgBox l_o_attachment.FileName
    Next l_o_attachment
    
    'supprimer le mail du dossier TMP de l'utilisateur
    On Error Resume Next: Kill l_s_pathMail: On Error GoTo 0
End Sub

A+

 

[Morning]

Bonjour mromain, et merci encore pour la réponse

N'étant pas expert du langage VB ( eh oui !!) ,
J'avais modifier un code existant pour l'adapter a mon besoin, celui ci est liée a une règle a réception de certaines adresse mail .

Sub REGLE_PJ_COA_BAK(courrier As MailItem) 'Déclarations Const dossier As String = "C:\Users\ME\Documents\-PERSO-\23-COA\01-BAK\" Dim extension As String Dim extrait As Boolean Dim pos As Long Dim PJ As Attachment If courrier.Attachments.Count = 0 Then ' ignorer le cas où il n'y a pas de pièce jointe 'MsgBox "Pas de pièce jointe, traitement abandonné", vbCritical Exit Sub End If extrait = False ' balayer les pièces jointes et filtrer For Each PJ In courrier.Attachments pos = InStrRev(PJ.FileName, ".") If pos > 0 Then extension = UCase(Mid(PJ.FileName, pos + 1)) '----- FILTRAGE à adapter----- If extension = "MSG" Or extension = "PDF" Or extension = "CSV" Then PJ.SaveAsFile dossier & PJ.FileName extrait = True End If End If Next PJ If extrait = False Then '' aucune pièce jointe extraite. ' choisir ce qui permet d'identifier le courrier, ici c'est le sujet, on peut mettre l'expéditeur, la date etc. MsgBox "Aucune pièce jointe n'a été extraite du courrier : " & courrier.Subject, vbExclamation Exit Sub End If Set courrier = Nothing ' ouvrir le dossier de sauvegarde pour affichage Shell "explorer.exe " & dossier, vbNormalFocus End Sub

J'ai bien compris ta proposition , mais je ne vois pas bien a quel moment l'intégrer dans ma macro actuelle .

j'aurais peux être du le préciser désolé

Merci encore