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, nom$, Email$
Dim OLmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
For Each SousDossier In Fld.Folders
If SousDossier.DefaultItemType = 0 And SousDossier = "PAYS" Then
For Each OLmail In SousDossier.Items
If Not OLmail.Attachments.Count = 0 Then
For y = 1 To OLmail.Attachments.Count
Email = OLmail.SentOnBehalfOfName
Select Case Split(OLmail.SentOnBehalfOfName, "@")(1)
Case "congo.com": nom = "\banane.xls"
Case "bresil.com": nom = "\sucre.xls"
End Select
Set pceJointe = OLmail.Attachments(y)
x = x + 1
pceJointe.SaveAsFile "C:\PRODUITS" & nom
Set pceJointe = Nothing
Next y
End If
Next OLmail
End If
SearchFolders SousDossier
Next SousDossier
End Sub