Option Explicit
'------------------------------------------------------------------------
'Nécessite d'activer la référence Microsoft Outlook xx.xx Object Library
'------------------------------------------------------------------------
Public 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
Dim chemin As String
chemin = "C:\Users\" & Environ("Username") & "\Desktop\"
For Each SousDossier In fld.Folders
'.Item("Nom_Du_Dossier").Items
If SousDossier.DefaultItemType = 0 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)
x = x + 1
pceJointe.SaveAsFile chemin & pceJointe
Set pceJointe = Nothing
Next y
End If
Next OLmail
End If
SearchFolders SousDossier
Next SousDossier
End Sub