Macro VBA de sauvegarde des pièces jointes + objets et corps de mail par dossiers

[jibi23]

Bonjour,

Mon système :
Win7
Outlook / Office 2010
64bits

Je travaille à partir d'un modèle téléchargé sur internet sur une macro VBA qui devrait me permettre de récupérer sur mon disque dur toute l'arborescence, avec les corps de mail, objet et PJ d'une boite de réception Outlook.

Je rencontre 3 blocages sur la macro actuelle :

-Je souhaite pouvoir filtrer les PJ sauvegardées en éliminant de la requête les fichiers autres que xls, xlsx, ppt, pptx, doc, docx, pdf.
- Je souhaite récupérer le corps et l'objet du mail correspondant dans le répertoire où se sauvegarde chaque PJ.
- Je souhaite insérer l'objet du mail au début du nom de la PJ sauvegardée.

J'ai essayé plusieurs techniques de filtrage d'extension de fichiers etc.. cela ne marche pas, je vous poste donc la macro d'origine sans ces 3 fonctions ci-dessus:

il est nécessaire d'activer Microsoft Scripting Runtime dans l’éditeur VBA d’outlook pour exécuter la macro.
Pour cela, lancer l'éditeur VBA et faire Outils > Références > cocher Microsoft Scripting Runtime dans la liste

'-- Variable globale contenant le répertoire de référence de sauvegarde
Dim REP_TOP As String

Sub Extrait_Pieces_Jointes()
'----------------------------------------------------------------------
' Routine :    Extrait_Pieces_Jointes
'----------------------------------------------------------------------
' Paramètres : aucun ...
'----------------------------------------------------------------------
'   retour :    Boite de dialogue "Terminé"
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

Dim myNameSpace As NameSpace, fld As MAPIFolder, pfld As MAPIFolder, sfld As MAPIFolder
Dim myItem As MailItem, Piece As Attachment
Dim doc As String, rep As String

    '-- Choix et contrôle du disque de destination
    rep = InputBox("Sur quel disque ?", "Question", "C:")
    On Error Resume Next
    ChDrive rep
    test = Err
    On Error GoTo 0
    
    If test Then
        MsgBox "Disque " & rep & " inaccessible"
        Exit Sub
    End If
    
    REP_TOP = rep & "\"
    
    '-- Choix et contrôle / création du répertoire de base
    rep = InputBox("Dans quel répertoire ?", "Question", "\temp\test\")
    
    test = waaps_creedir(rep)
    
    If Not test Then
        MsgBox "Répertoire " & rep & " inaccessible"
        Exit Sub
    End If
    
    '-- Initialisation de la variable globale du répertoire de référence
    REP_TOP = REP_TOP & "\" & rep
    REP_TOP = Replace(REP_TOP, "/", "\")
    REP_TOP = Replace(REP_TOP, "\\", "\")
    
    '-- Récupération de l'espace nommé MAPI
    Set myNameSpace = CreateObject("Outlook.Application").GetNamespace("MAPI")
    
    '-- Choix du dossier à traiter ... c'est un MAPIFolder
    Set pfld = myNameSpace.PickFolder
    
    '-- Si l'utilisateur renonce on s'en va
    If pfld Is Nothing Then Exit Sub
    
    '-- appel de la routine sauvefolder ...
    sauvefolder pfld, ""
    
    MsgBox "terminé"

End Sub


Sub sauvefolder(fld As MAPIFolder, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefolder (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    fld : Le MAPIFolder à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

    '-- on entretient la localisation sur la base du nom de dossier courant
    suf = suf & fld.Name & "\"
    
    '-- On envoie une info dans la fenêtre debug pour ceux qui aiment voir ce qui se passe
    Debug.Print suf & fld.Items.Count
    
    '-- On tourne sur tous les éléments du dossier courant
    For i = 1 To fld.Items.Count
        '-- Si c'est un élément de type Mail alors on sauvegarde les pièces jointes associées
        If fld.Items(i).Class = olMail Then sauvefichier fld.Items(i), suf
        '-- Pour voir ce qui se passe sans tout faire ... enlever le commentaire ci-dessous
        'If i = 2 Then Exit For
    Next
    
    '-- On tourne sur tous les sous-dossiers du dossier courant
    For i = 1 To fld.Folders.Count
        '-- appel récursif de la fonction sauvefolder
        sauvefolder fld.Folders(i), suf
    Next

End Sub

Sub sauvefichier(myItem As MailItem, ByVal suf As String)
'----------------------------------------------------------------------
' Routine :    sauvefichier (routine récursive...)
'----------------------------------------------------------------------
' Paramètres :
'    myItem : l'item Mail à traiter
'    suf : localisation /nomdedossier/nomdedossier2/
'----------------------------------------------------------------------
'   retour :    Aucun
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------

Dim Piece As Attachment

    '-- on s'assure de la création / existence du répertoire de stockage
    waaps_creedir (suf)

    '-- On boucle sur les pièces jointes du message (si il y en a)
    For j = 1 To myItem.Attachments.Count
        '-- Initialisation de l'objet Pièce Jointe
        Set Piece = myItem.Attachments(j)
        '-- Sauvegarde du fichier correspondant.
        Piece.SaveAsFile REP_TOP & suf & j & "_" & Piece.FileName
    Next
    Set Piece = Nothing
End Sub

Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
Dim fso As FileSystemObject, i As Integer, retour As Boolean
Dim rp As String, r

    Set fso = CreateObject("Scripting.filesystemobject")
    
    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.folderexists(r)) Then
                fso.createfolder (CStr(r))
                If (Not fso.folderexists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function

Je précise que je sais qu'il existe des Soft et freeware pour le faire, mais on ne peut en utiliser aucun sur nos postes de travail, donc la seule solution est la macro.

Quelqu'un aurait-il la motivation de jeter un œil ?
Je vous remercie par avance,