Microsoft 365 Extraction contenu mail outlook vers excel

[raf26]

Bonjour,

Je reçois chaque jour plusieurs mail du même expéditeur et le sujet commençant toujours par "nouveau contrôle...."

Je copie manuellement le contenu du mail dans une cellule de mon tableau Excel et le classe dans un sous dossier (un par mois) de ma boite de réception Outlook.

Je souhaite automatiser cette tache répétitive.

J'ai trouvé cette macro sur le net, adaptée à mes cellules et aux mails reçus

Toutefois la macro plante sur

 lastMessage.Display

Je vous joins la macro complete

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

D'avance merci pour vos contributions.

Bonne journée.

 

[fanch55]

Personnellement j'aurais travailler la Macro sur Outlook sur l'événement de réception des mails.

Bonjour @dysorthographie
Moi aussi, mais je ne connais pas le classeur excel dans son ensemble et je suppose qu'il doit y avoir un impératif quelconque ...

 

[raf26]

Bonjour,

Votre dernière macro marche excellemment bien !

Bravo et grand grand merci pour le temps passé et votre talent.

Juste une dernière chose :

Si ma boite de réception ne contient aucun message avec l'expéditeur ou le sujet du mail précisé dans la macro, comment en sortir ?

J'ai essayé d'adapter

If N < 0 Then Exit Sub

mais cela ne fonctionne pas

 

[fanch55]

Tel qu'est fait le code, en cas de message non trouvé, vous arriverez sur le message ci-contre et sortirez de la sub .

 

[raf26]

Bah oui....évidemment. !

Je cloture ce fil en marquant le message #15 comme solution.

Je tiens à nouveau à vous remercier et vous féliciter sincèrement pour l'aide apportée.