[Outlook 2010] Macro VBA to save from inbox : Folder / Email Subject / Body / Attache

Hi,


My system is :
Win7
Outlook / Office 2010
64bits


I am working on a macro VBA under Outlook2010 which should allow me to save the entire hierarchy of an inbox folders and the matching emails + attached docs


I have this code below which works for selecting the inbox folder to backup, and then the harddrive where to save and then save the attached docs,


I still have 3 problems :


- I wish to save only attached files with xls, xlsx, ppt, pptx, doc, docx, pdf.
- I wish to recover the mail body in the matching hard drive folder.
- I wish to insert the mail subject in the file name of the backuped attached document on the hard drive.


Microsoft Scripting Runtime activation is required

Code:

---

'-- 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

---

Any kind of help would be appreciated,
Thanks by advance,
Regards