Copie liste de messages Outlook dans excel

Option Explicit
'
' Listing 11.6. A procedure that reads Inbox data into a worksheet.
'
Sub ReadInboxData()'Sub LireMailsObjets()
    Dim ol As Outlook.Application
    Dim ns As NameSpace
    Dim folder As MAPIFolder
    Dim ws As Worksheet
    Dim i As Integer
    '
    ' Establish a connection and log on
    '
    Set ol = CreateObject("Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    ns.Logon
    '
    ' Get the default Inbox folder and set Receive Mail worksheet
    '
    Set folder = ns.GetDefaultFolder(olFolderInbox)
'+++++++++++' modifs
    Set folder =ns.GetDefaultFolder(olFolderSentMail)
'+++++++++++
'+++++++++++ 'modifs
    Set ws = Worksheets("Emails reçus"")
'il faut qu'il y ait une fuille avec ce nom
'ou alors adapter avec le nom de ton choix
'++++++++++
    'Set ws = Worksheets("Receive Mail")
    '
    ' Run through each item in the Inbox
    '
    For i = 1 To folder.Items.Count
        With folder.Items(i)
            '
            ' Record the sender, subject, size,
            ' received time, and some of the body
            '
            ws.[A1].Offset(i, 0) = .SenderName
            ws.[A1].Offset(i, 1) = .SenderEmailAddress
            ws.[A1].Offset(i, 2) = .Subject
            ws.[A1].Offset(i, 3) = .Size
            ws.[A1].Offset(i, 4) = .ReceivedTime
            ws.[A1].Offset(i, 5) = Left(.Body, 100)
        End With
    Next 'i
    '
    ' Log off the session
    '
    ns.Logoff
    Set ol = Nothing
End Sub

Sub ListeSujet()
    Dim SessionMapi As MSMAPI.MapiSession
    Dim MessagesMapi As MSMAPI.MapiMessages
    Dim Cpt As Integer
    
    Set SessionMapi = New MSMAPI.MapiSession
    With SessionMapi
        .LogonUI = False
        .SignOn
    End With

    Set MessagesMapi = New MSMAPI.MapiMessages
    With MessagesMapi
        .SessionID = SessionMapi.SessionID
        .Fetch
        
        For Cpt = 0 To .MsgCount - 1
            .MsgIndex = Cpt
            On Error Resume Next
                Feuil1.Range("A" & Feuil1.Range("A65536").End(xlUp).Row + 1) = .MsgSubject
            On Error GoTo 0
        Next
    End With

    SessionMapi.SignOff
End Sub

Option Explicit

Sub Import_Mails_NonLus()
    Dim ol As Outlook.Application
    Dim ns As NameSpace
    Dim folder As MAPIFolder
    Dim ws As Worksheet
    Dim i As Integer
   
    Set ol = CreateObject("Outlook.Application")
    Set ns = ol.GetNamespace("MAPI")
    ns.Logon

    Set folder = ns.GetDefaultFolder(olFolderInbox)
 
    Set ws = Worksheets("Emails recus")

    For i = 1 To folder.Items.Count
        With folder.Items(i)
        'liste les messages non lus
            ws.[A1].Offset(i, 0) = .UnRead
            ws.[A1].Offset(i, 1) = .Subject
            ws.[A1].Offset(i, 2) = .Size
            ws.[A1].Offset(i, 3) = Left(.Body, 100)
        End With
    Next i
    ns.Logoff
    Set ol = Nothing
End Sub