Outlook - Sauvegarder toutes les pièces jointes

'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

Lien vers le fichier : cliquez ici