Sauve PJ d'outlook (boite de réception) sous c:\pj\ via Exce

Hello,

Voici une macro qui peut faire l'affaire :

Note: il faut, dans l'interface VBA, aller dans Outils > Référence puis chercher et cocher "Microsoft Outlook 14.0 Object Library" avant de pouvoir utiliser cette macro.

Sub EnregistrerLesPiecesJointesEtDeplacerLesEmails()
    
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim objAttachment As Attachment
    Dim strFolderPath As String
    Dim strFolderName As String
    
    ' Spécifiez le chemin du dossier où les pièces jointes seront enregistrées
    strFolderPath = "C:\pj\"
    
    ' Spécifiez le nom du dossier où les emails traités seront déplacés
    strFolderName = "Traité"
    
    On Error Resume Next
    
    ' Instancie un objet application Outlook
    Set objOL = CreateObject("Outlook.Application")
    
    ' Obtient le namespace MAPI
    Set objNS = objOL.GetNamespace("MAPI")
    
    ' Obtient le dossier Boîte de réception
    Set objFolder = objNS.GetDefaultFolder(olFolderInbox)
    
    ' Parcourt chaque élément dans le dossier Boîte de réception
    For Each objItem In objFolder.Items
        
        ' Vérifie si l'élément est un MailItem
        If objItem.Class = olMail Then
            
            ' Parcourt chaque pièce jointe dans le MailItem
            For Each objAttachment In objItem.Attachments
                
                ' Enregistre la pièce jointe dans le chemin du dossier spécifié
                objAttachment.SaveAsFile strFolderPath & objAttachment.FileName
                
            Next objAttachment
            
            ' Déplace le MailItem dans le dossier spécifié
            objItem.Move objFolder.Folders(strFolderName)
            
        End If
        
    Next objItem
    
    Set objAttachment = Nothing
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objNS = Nothing
    Set objOL = Nothing
    
    MsgBox "Les pièces jointes ont été enregistrées et les emails ont été déplacés.", vbInformation
    
End Sub

Sub EnregistrerLesPiecesJointesEtDeplacerLesEmails()
    
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim objAttachment As Attachment
    Dim strFolderPath As String
    Dim strFolderName As String
    Dim strSharedEmail As String

 ' Chemin du dossier spécifié en H1
 strFolderPath = Range("h1").Value
    
' Adresse e-mail du compte partagé (générique)
strSharedEmail = Range("h8").Value

 ' Spécifiez le nom du dossier où les emails traités seront déplacés
 strFolderName = Range("h4").Value
'  "Terminés-traités"
    
 On Error Resume Next ' gestion des erreurs
    
' Instancie un objet application Outlook
Set objOL = New Outlook.Application
' Obtient le namespace MAPI
Set objNamespace = objOL.GetNamespace("MAPI")

' Obtient le dossier Boîte de réception
Set objFolder = objNamespace.GetSharedDefaultFolder(objNamespace.CreateRecipient(strSharedEmail), olFolderInbox)

' Obtenir une référence au dossier "Traité"
    Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).Folders(strFolderName)
    
' Parcourt chaque élément dans le dossier Boîte de réception
For Each objItem In objFolder.Items
        
 ' Vérifie si l'élément est un MailItem
 If objItem.Class = olmail Then
            
 ' Parcourt chaque pièce jointe dans le MailItem
 For Each objAttachment In objItem.Attachments
                
 ' Enregistre la pièce jointe dans le chemin du dossier spécifié
 objAttachment.SaveAsFile strFolderPath & objAttachment.Filename
                
 Next objAttachment 'suivant
            
 ' Déplace le MailItem dans le dossier spécifié..........................NE FONCTIONNE PAS le déplacement se fait sur le dossier de ma bal et non sur le dossier de ma bal spécifiée....
 objItem.Move objDestFolder
            
 End If
        
 Next objItem ' suivant
    
    Set objAttachment = Nothing
    Set objItem = Nothing
    Set objFolder = Nothing
    Set objNS = Nothing
    Set objOL = Nothing
    
    MsgBox "Les pièces jointes ont été enregistrées et les emails ont été déplacés ! Merci d'avoir patienté ......"", vbInformation"
    
End Sub