Macro enregistrer pièce jointe Outlook

Bonjour,

J’ai récupéré un code macro qui permet de sauvegarder la pièce jointe d’un mail vers un dossier spécifique.

Je souhaiterais inclure dans cette macro, un code qui me permettrait d’enregistrer toutes les pièces jointes provenant des personnes ayant pour mail .…@société-a.com sous un nouveau nom.

Exemple :

Si l'expéditeur a pour mail .....@societe-A.com en pièce jointe "ventes.xls" Enregistrer le fichier sous "synthese.xls"

et si l'expéditeur a pour mail .....@société-B.com en pièce jointe "produits.xls" Enregistrer le fichier sous "prix de vente.xls"

Est-ce réalisable ?

En vous remerciant.

Sub SaveAttachment()

'Declaration
Dim myItems, myItem, myAttachments, 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

'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

'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
myItem.Body = myItem.Body & _
"File: " & myOrt & _
myAttachments(i).DisplayName & vbCrLf

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

Bonsoir sophang,

Je n'ai pas Outlook sous la main donc pas sûr que ça marche mais essaie avec cette macro :

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

    '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": nomFichier = "synthese.xls"
                Case ".....@société-B.com": nomFichier = "prix de vente.xls"
                End Select

                '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

            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

Je te laisse adapter les adresses mail ainsi que les noms de fichier.

Une remarque concernant cette ligne :

Dim myItems, myItem, myAttachments, myAttachment As Object

En VBA, afin que les variables soient toutes de type Object, il est nécessaire de les déclarer une à une. Avec la syntaxe que tu utilises, seule la variable myAttachment sera déclarée comme un Object. Les autres seront de type Variant.

Si tu veux toutes les déclarer en Object, il faut faire comme cela :

Dim myItems As Object, myItem As Object, myAttachments As Object, myAttachment As Object

Bonjour,

J'ai adapté ta macro, et çà marche superbement bien !

Merci.

Cependant, je rencontre juste un petit problème si l'espéditeur m'envoie une pièce jointe avec un fichier Excel avec une extension .xlsx.

J'ai mis l'extension .xlsx, mais çà ne marche pas. ça ne me copie pas la pièce jointe.

As-tu une solution ?

Re,

Pas facile à l'aveugle. Je ne sais pas trop. Peut-être faut-il tester l'extension du fichier au préalable ?

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

De plus, quand tu dis que ça ne marche pas, y a-t-il un message d'erreur quelconque ?

Bonjour Vba-new,

J'ai adapté la macro à mon cas, et cà marche bien. Le seul inconconvénient, c'est que je dois séléctionner les mails des expéditeurs pour lesquels je veux copier les pièces jointes, malgré qu'il y a les adresses mails des expéditeurs définis dans le code de la macro.

Faut-il redéfinir le code ?

Re,

Qu'entends-tu par :

sophang a écrit :

Le seul inconconvénient, c'est que je dois séléctionner les mails des expéditeurs pour lesquels je veux copier les pièces jointes

J'ai compris. C'est normal car dans ton code, il y a ces lignes là :

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

Peut-être une solution avec ce code :

Sub PJ()

'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
    Dim myNamespace As Outlook.Namespace
    Dim myInbox As MAPIFolder

    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "\\192.168.4.1\tresorerie\COMMUN\REPORTING\Macros Tréso\Positions comptes bancaires Filiales étrangères\")

    On Error Resume Next

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

    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)

    'boucle
    'For Each myItem In myOlSel
    For Each myItem In myInbox.Items 'boucle sur toutes les éléments de la boîte de réception
        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 "......@.....ch": nomFichier = "CH - Tréso.xls"
                Case ".......@shp.ie": nomFichier = "IE - Tréso.xls"
                Case "........@......net": nomFichier = "DE - Tréso.xls"
                Case ".......@........aero": nomFichier = "CG CPTS - Tréso.xls"
                Case "...........@.......aero": nomFichier = "CG HANDLING - Tréso.xls"
                Case "...........@........com": nomFichier = "ES - Tréso.xls"
                Case "...........@..........com": nomFichier = "US - Tréso.xls"
                End Select

                '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

            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
    Set myNamespace = Nothing
    Set myInbox = Nothing

End Sub

Attention, plutôt que de boucler sur les éléments sélectionnés, on va boucler sur toute la boîte de réception des mails. S'il y a beaucoup d'éléments, ça peut prendre du temps...

Bonjour,

Effectivement, je n’avais pas pensé que boucler sur toute la boîte de réception prenait vraiment beaucoup de temps, car il y a une multitude de mails des mêmes expéditeurs.

Peut-on alors spécifier dans ce cas dans le code de la macro, de boucler dans un dossier spécifique de Outlook ?

Oui c'est possible.

Crée au préalable un dossier nommé "Le_nom_de_ton_dossier" dans ta boîte de réception et utilise le code suivant :

Sub PJ()

'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
    Dim myNamespace As Outlook.Namespace
    Dim myInbox As MAPIFolder
    Dim mySearchFolder As MAPIFolder

    'Boîte de dialogue simple pour le chemin de sauvegarde
    myOrt = InputBox("Destination", "Save Attachments", "\\192.168.4.1\tresorerie\COMMUN\REPORTING\Macros Tréso\Positions comptes bancaires Filiales étrangères\")

    On Error Resume Next

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

    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set mySearchFolder = myInbox.Folders("Le_nom_de_ton_dossier")

    'boucle
    'For Each myItem In myOlSel
    For Each myItem In mySearchFolder.Items    'boucle sur toutes les éléments du sous-dossier créé dans la boîte de réception
        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 "......@.....ch": nomFichier = "CH - Tréso.xls"
                Case ".......@shp.ie": nomFichier = "IE - Tréso.xls"
                Case "........@......net": nomFichier = "DE - Tréso.xls"
                Case ".......@........aero": nomFichier = "CG CPTS - Tréso.xls"
                Case "...........@.......aero": nomFichier = "CG HANDLING - Tréso.xls"
                Case "...........@........com": nomFichier = "ES - Tréso.xls"
                Case "...........@..........com": nomFichier = "US - Tréso.xls"
                End Select

                '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

            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
    Set myNamespace = Nothing
    Set myInbox = Nothing
    Set mySearchFolder = Nothing

End Sub

Bonjour vba-new,

Vraiment cool, merci !