Enregistrer pièces jointes

Enregistrer les pièces jointes dans un dossier

Sub SaveAttachments(strPath As String)
    '/
    '/ Nécessite la référence suivante:
    '/ Microsoft Outlook xx Object Library
    '/
    '/ Syntaxe : Call SaveAttachments("F:\Mes Documents")
    '
    Dim Ol_App As New Outlook.Application
    Dim Ol_MAPI As Outlook.NameSpace
    Dim Ol_Items As Outlook.Items
    Dim Ol_Item As Outlook.MailItem
    '
    Dim strAttachment As String
    Dim NbAttachments As Integer
    Dim i As Integer
    Dim NbEmails As Integer
    '
    Set Ol_MAPI = Ol_App.GetNamespace("MAPI")
    Set Ol_Items = Ol_MAPI.PickFolder.Items
    '
    For Each Ol_Item In Ol_Items
        NbAttachments = Ol_Item.Attachments.Count
        i = 1
        Do While i <= NbAttachments
            strAttachment = Ol_Item.Attachments.Item(i).FileName
            Ol_Item.Attachments.Item(i).SaveAsFile strPath & strAttachment
            i = i + 1
        Loop
    Next Ol_Item
    '
    Set Ol_Item = Nothing
    Set Ol_Items = Nothing
    Set Ol_MAPI = Nothing
    Set Ol_App = Nothing
End Sub