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]

Bonjour,
Vous avez ce message d'erreur si aucun message ne correspond à vos critères .
Code modifié et corrigé ci-dessous.

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"):    cellB3.ClearContents
    subFolderName = ThisWorkbook.Worksheets("Qualite").Range("E1"):
   
    ' 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
    N = 0
    For Each lastMessage In outlookItems
        If lastMessage.SenderName = "qualite@test.com" _
        And lastMessage.Subject Like "Nouveau controle*" Then
            If cellB3 <> "" Then If MsgBox("Message suivant,continuer ?", vbQuestion + vbOKCancel) = vbCancel Then Exit For
           ' Copier le contenu du message dans la cellule
            cellB3 = lastMessage.Body
            If subFolderName <> "" Then
                ' Déplacer le message dans le sous-dossier nommé selon la cellule E1
                On Error Resume Next
                Set subFolder = outlookFolder.Folders(subFolderName)
                If subFolder Is Nothing Then Set subFolder = outlookFolder.Folders.Add(subFolderName)
                On Error GoTo 0
                lastMessage.Move subFolder
                lastMessage.UnRead = False
            End If
            N = N + 1
        End If
    Next
    MsgBox "Fin de la sub d'extraction" & vbLf & N & " mail(s) traité(s)"
   
End Sub

 

[raf26]

bonjour @fanch55

Super impressionnant !!!

je voudrais modifier 2 points :

Coller dans le presse papier le body du message au lieu de le coller en B3
j'ai essayé avec clipboard mais cela ne fonctionne pas

Le déplacement dans le sous dossier : ce sous dossier devra être crée s'il n'existe pas dans dossier "Suivi controle" de la boite de réception.
Actuellement (et c'est normal), le sous dossier est crée dans la boite de réception

Merci

Cordialement

 

[fanch55]

Autant faire une copy de la cellule quand elle a été remplie, cela servira de vérification potentielle .

Option Compare Text
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"):    cellB3.ClearContents
    subFolderName = ThisWorkbook.Worksheets("Qualite").Range("E1")
 
    ' 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
    N = 0
    For Each lastMessage In outlookItems
        If lastMessage.SenderName = "qualite@test.com" _
        And lastMessage.Subject Like "Nouveau controle*" Then
            If cellB3 <> "" Then If MsgBox("Message suivant,continuer ?", vbQuestion + vbOKCancel) = vbCancel Then Exit For
           ' Copier le contenu du message dans la cellule
            cellB3 = lastMessage.Body
            If subFolderName <> "" Then
                ' Déplacer le message dans le sous-dossier nommé selon la cellule E1
                On Error Resume Next
                Set subFolder = outlookFolder.Folders("Suivi controle").Folders(subFolderName)
                If subFolder Is Nothing Then Set subFolder = outlookFolder.Folders("Suivi controle").Folders.Add(subFolderName)
                On Error GoTo 0
                lastMessage.Move subFolder
                lastMessage.UnRead = False
            End If
            cellB3.Copy
            N = N + 1
        End If
    Next
    MsgBox "Fin de la sub d'extraction" & vbLf & N & " mail(s) traité(s)"
 
End Sub

 

[raf26]

Re @fanch55

Merci de retour, super

Pour la cellule B3, la macro colle le body dans son intégralité dans la cellule.

cellB3 = lastMessage.Body

Je n’arrive pas à modifier le body format pour que le collage se fasse en collage spécial format texte, en gardant le format d’origine du mail.

Le body du mail contient de 1 à + de 200 lignes lignes et toujours sur 2 colonnes