Importer les messages

Importer les messages d'un dossier Outlook dans une table

Si la table d'importation n'existe pas, elle est créée par requête SQL

Sub ImportMails()
    On Error Resume Next
    Dim strAttachment As String
    Dim strSql As String
    Dim rsMail As DAO.Recordset
    Dim tdf As DAO.TableDef
    Dim Ol_App As New Outlook.Application
    Dim Ol_MAPI As Outlook.NameSpace
    Dim Ol_Folder As Outlook.MAPIFolder
    Dim Ol_Items As Outlook.MailItem
    Dim Ol_Attach As Outlook.Attachment

    Set tdf = CurrentDb.TableDefs("TblMails")

    If tdf Is Nothing Then
        strSql = "CREATE TABLE TblMails (" & _
                 "CreationTime DATE," & _
                 "LastModificationTime DATE," & _
                 "SenderName CHAR(50)," & _
                 "SenderAddress CHAR(50)," & _
                 "SentOn DATE," & _
                 "Sent YESNO," & _
                 "TO CHAR(255)," & _
                 "CC CHAR(255)," & _
                 "BCC CHAR(255)," & _
                 "UnRead YESNO," & _
                 "ReceivedByName CHAR(50)," & _
                 "ReceivedOnBehalfOfName CHAR(100)," & _
                 "ReceivedTime DATE," & _
                 "ConversationTopic CHAR(255)," & _
                 "Subject CHAR(255)," & _
                 "Categories CHAR(50)," & _
                 "HTMLBody MEMO," & _
                 "Size Long," & _
                 "Attachments CHAR(255));"
        CurrentDb.Execute strSql
    End If

    Set rsMail = CurrentDb.OpenRecordset("TblMails")
    Set Ol_MAPI = Ol_App.GetNamespace("MAPI")
    Set Ol_Folder = Ol_MAPI.PickFolder
    
    For Each Ol_Items In Ol_Folder.Items
        For Each Ol_Attach In Ol_Items.Attachments
            strAttachment = strAttachment & Ol_Attach.DisplayName & vbCrLf
        Next Ol_Attach

        With rsMail
            .AddNew
            .Fields("BCC") = Ol_Items.Bcc
            .Fields("Categories") = Ol_Items.Categories
            .Fields("CC") = Ol_Items.Cc
            .Fields("ConversationTopic") = Ol_Items.ConversationTopic
            .Fields("CreationTime") = Ol_Items.CreationTime
            .Fields("HTMLBody") = Ol_Items.HTMLBody
            .Fields("LastModificationTime") = Ol_Items.LastModificationTime
            .Fields("ReceivedByName") = Ol_Items.ReceivedByName
            .Fields("ReceivedOnBehalfOfName") = Ol_Items.ReceivedOnBehalfOfName
            .Fields("ReceivedTime") = Ol_Items.ReceivedTime
            .Fields("SenderName") = Ol_Items.SenderName
            .Fields("Sent") = Ol_Items.Sent
            .Fields("SentOn") = Ol_Items.SentOn
            .Fields("SenderAddress") = Ol_Items.ReplY.Recipients.Item(1).Address
            .Fields("Size") = Ol_Items.Size
            .Fields("Subject") = Ol_Items.Subject
            .Fields("TO") = Ol_Items.To
            .Fields("UnRead") = Ol_Items.UnRead
            .Fields("Attachments") = strAttachment
            .Update
        End With
        strAttachment = ""
    Next Ol_Items

    rsMail.Close
    MsgBox "Les données ont été importées"

    Set rsMail = Nothing
    Set tdf = Nothing
    Set Ol_Attach = Nothing
    Set Ol_Items = Nothing
    Set Ol_Folder = Nothing
    Set Ol_MAPI = Nothing
    Set Ol_App = Nothing
End Sub