Microsoft 365 Extraction contenu mail outlook vers excel

 lastMessage.Display

Sub Extract()
    
    Dim outlookApp  As Outlook.Application
    Dim outlookNamespace As namespace
    Dim outlookFolder As MAPIFolder
    Dim outlookItems As items
    Dim lastMessage As mailItem
    Dim cellB3      As Range
    Dim cellE1      As Range
    Dim subFolderName As String
    Dim subFolder   As MAPIFolder
    
    ' Sélectionner la cellule B3 de la feuille Qualite
    Set cellB3 = ThisWorkbook.Worksheets("Qualite").Range("B3")
    
    ' Ouvrir l'application Outlook
    Set outlookApp = New Outlook.Application
    Set outlookNamespace = outlookApp.GetNamespace("MAPI")
    
    ' Accéder à la boîte de réception
    Set outlookFolder = outlookNamespace.GetDefaultFolder(olFolderInbox)
    
    ' Rechercher le dernier message avec l'expéditeur "qualite@test.com" et l'objet "Nouveau controle(XXXX ...ces numéros changent automatiquement) a éte effectue"
    Set outlookItems = outlookFolder.items
    outlookItems.Sort "[ReceivedTime]", True
    
    For Each lastMessage In outlookItems
        If lastMessage.SenderName = "qualite@test.com" And lastMessage.Subject = "Nouveau controle" Then
            Exit For
        End If
    Next
    
    ' Copier le contenu du message dans le presse-papiers
    lastMessage.Display
    SendKeys "^a^c"
    
    ' Déplacer le message dans le sous-dossier nommé selon la cellule E1
    Set cellE1 = ThisWorkbook.Worksheets("Qualite").Range("E1")
    subFolderName = cellE1.Value
    If outlookFolder.Folders.Exists(subFolderName) Then
        Set subFolder = outlookFolder.Folders(subFolderName)
    Else
        Set subFolder = outlookFolder.Folders.Add(subFolderName)
    End If
    
    lastMessage.Move subFolder
    lastMessage.UnRead = False
    
End Sub