'Version du 17 décembre 2012 'Macro a déclarere dans office Sub SauvegarderPiecesattachees() Dim OlApp As Outlook.Application Dim objItem As Outlook.MailItem Dim NbrPiecesAttachees As Integer Dim nomFichier As String Dim NumeroFichierAttache Dim Compteur Set OlApp = New Outlook.Application On Error Resume Next Compteur = 1 For Each objItem In Application.ActiveExplorer.Selection NbrPiecesAttachees = objItem.Attachments.Count 'If NbrPiecesAttachees > 0 Then 'introduction d'une ligne de séparation dans le corps du mail 'objItem.Body = "----- " & vbCr & objItem.Body 'End If For NumeroFichierAttache = 1 To NbrPiecesAttachees Step 1 'place le nom du fichier qui va être supprimé dans le corps du mail nomFichier = objItem.Attachments.Item(NumeroFichierAttache).FileName 'objItem.Body = ">> Attachement: " & nomFichier & vbCrLf & objItem.Body 'objItem.Attachments.Remove (1) 'suppression de la piece jointe 'objItem.Save 'enregistrer le message pour remettre à jour la collection d'attachement 'objItem.Attachments.Item(NumeroFichierAttache).SaveAsFile ("E:\" + Compteur + nomFichier) objItem.Attachments.Item(NumeroFichierAttache).SaveAsFile ("E:\" & Compteur & nomFichier) Compteur = Compteur + 1 Next Next Set objItem = Nothing End Sub