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

Question

Bonjour,

Malgré les différents posts sur le sujet, je n'ai pas trouvé comment sauvegarder automatiquement les pièces jointes sous un répertoire (exemple : C:\pj\, à l'arrivée du mail sous OUTLOOK 2010, puis de classer le mail dans un dossier (Boite de réception\Traité).

Mon problème, c'est de créer une règle en lançant un script (vba). Je ne trouve pas exécuter un script, car une sécurité en entreprise interdit cela.....

Du coup, est-il possible à partir d'excel, de sauvegarder les pièces jointes de la boite de réception d'outlook, sous un répertoire c:\pj\ et ensuite sous outlook de déplacer ces mails avec pièce joint dans le dossier "Traité" ?

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
Dim olmail 'As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim SousDossier As Outlook.MAPIFolder
 
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 "C:\PJ\" & x & "_" & pceJointe
                    Set pceJointe = Nothing
                Next y
            End If
        Next olmail
    End If
    SearchFolders SousDossier
Next SousDossier
End Sub

Ce code, balaie tous les dossiers de la boite de réception. Mon souhait serait de ne balayer que la boite de réception..

Comment remplacer :

For Each SousDossier In fld.Folders
....
Next SousDossier

pour lui indiquer, que seule la boite de réception et non les sous dossiers....

Merci d'avance !

Bien cordialement,

Merci pour votre aide !

Bien cordialement,

Windows / Edge 112.0.1722.68

ozone_ · Accepted Answer

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

PYGOS69 · Answer

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

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

2 réponses

Discussions similaires

Newsletters