Microsoft 365 Extraction contenu mail outlook vers excel

raf26 · 3 Novembre 2024

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

VB:

 lastMessage.Display

Je vous joins la macro complete

Code:

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 · 8 Novembre 2024

En partant de la base du message ci-dessous :

Ce code raccourci devrait répondre à la demande :

VB:

Option Compare Text
Sub Extract()
 
    Dim outlookApp  As Outlook.Application
    Dim outlookFolder As MAPIFolder
    Dim lastMessage As mailItem
    Dim subFolderName As String
    Dim subFolder   As MAPIFolder
 
    ' Sélectionner la cellule B3 de la feuille Qualite
    ThisWorkbook.Worksheets("Qualite").Activate
    subFolderName = [E1]
 
    ' Ouvrir l'application Outlook
    Set outlookApp = New Outlook.Application
    ' Accéder à la boîte de réception
    Set outlookFolder = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
 
    N = 0
 
    For Each lastMessage In outlookFolder.items
 
'        If...

fanch55 · 3 Novembre 2024

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

VB:

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 · 4 Novembre 2024

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 · 4 Novembre 2024

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

VB:

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 · 4 Novembre 2024

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

fanch55 · 6 Novembre 2024

Désolé, j’étais absent mardi .
Sans savoir exactement ce que vous attendez à recevoir, essayez le code ci-dessous.
On met le contenu texte du mail dans une zone de texte excel et on le met également dans le presse-papier .

VB:

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)
  
    N = 0
    
    For Each lastMessage In outlookFolder.items
    
'        If lastMessage.SenderName Like "*Amazon Marketplace*" Then
        If lastMessage.SenderName = "qualite@test.com" _
        And lastMessage.Subject Like "Nouveau controle*" Then
            If N > 0 Then If MsgBox("Un autre Message existe ,continuer ?", vbQuestion + vbOKCancel) = vbCancel Then Exit For
           ' destruction de la zone de texte de nom Mailtext
            On Error Resume Next: [Mailtext].Delete: On Error GoTo 0
           ' Copier le contenu du message dans la zone de texte recréée
            ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, cellB3.Left, cellB3.Top, 1, 1).Name = "MailText"
            With [Mailtext].ShapeRange.TextFrame2
                .TextRange.Characters.Text = HtmlToText(lastMessage.HTMLBody)
                .AutoSize = msoAutoSizeShapeToFitText
                .WordWrap = msoFalse
                .MarginLeft = 0: .MarginRight = 0: .MarginTop = 0: .MarginBottom = 0
                .Parent.Fill.ForeColor.RGB = RGB(255, 255, 204)
               ' Copie du contenu dans le presse-papier
                With New MSForms.DataObject
                    .SetText [Mailtext].Text
                    .PutInClipboard
                End With
                [E1].Select
            End With
          
            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
            N = N + 1
        End If
    Next
    MsgBox "Fin de la sub d'extraction" & vbLf & N & " mail(s) traité(s)"
  
End Sub
Function HtmlToText(sText) As String
    Dim oHFile As Object
    Set oHFile = CreateObject("HTMLFile")
        oHFile.Body.innerHTML = sText
        HtmlToText = oHFile.Body.innerText
'        HtmlToText = oHFile.Body.textcontent
    Set oHFile = Nothing
End Function

raf26 · 6 Novembre 2024

Re @fanch55

Grand merci de me consacrer du temps.

J'ai une erreur avec la fonction

Concernant l'extraction du body du mail, actuellement je copie et colle en spécial texte
afin que chaque ligne du mail soit sur une ligne Excel et idem pour les colonnes (il y en a 2)

Concernant le résultat que je recherche

Le mail contient les 11 premières lignes quasi identiques et ensuite il peut avoir de 1 à 200 lignes (qui celles ci sont toutes avec bordure en bas), exemple en PDF ci-joint.

Je joins un exemple un fichier avec le mail collé en texte, ligne par ligne et sur 2 colonnes, ce que je cherche à obtenir avec la macro

fanch55 · 6 Novembre 2024

raf26 à dit:
J'ai une erreur avec la fonction

Testez le classeur ci-joint, je ne vois pas la cause du problème clairement ...

fanch55 · 6 Novembre 2024

raf26 à dit:
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.

On s'écarte de la demande initiale ...

Si vous pouviez me transférer un mail-exemple véritable ( s'il n'y a pas de confidentialité forte ) à l'adresse que vous trouverez dans les conversation privées :

fanch55 · 7 Novembre 2024

Qu'est-ce que cela donne avec le classeur fourni ?

raf26 · 7 Novembre 2024

Bonsoir
Je n’ai pas eu le temps de tester.
J.essaye demain matin

raf26 · 8 Novembre 2024

Bonjour @fanch55

Je viens de tester ton fichier, cela est ok (juste le corps du mail est sur 1 seule colonne, mais je vais réussir à séparer les infos de la 2ème colonne). Bravo

Par contre, j'ai intégré la macro dans mon fichier et j'ai encore cette erreur

fanch55 · 8 Novembre 2024

raf26 à dit:
Par contre, j'ai intégré la macro dans mon fichier et j'ai encore cette erreur

Rajoutez la référence HTML au code :

dysorthographie · 8 Novembre 2024

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

Si tu défini outlook dans le menu démarrer de Windows alors tes mails seront extrait d'outlook automatiquement à leurs réception.

fanch55 · 8 Novembre 2024

En partant de la base du message ci-dessous :

Ce code raccourci devrait répondre à la demande :

VB:

Option Compare Text
Sub Extract()
 
    Dim outlookApp  As Outlook.Application
    Dim outlookFolder As MAPIFolder
    Dim lastMessage As mailItem
    Dim subFolderName As String
    Dim subFolder   As MAPIFolder
 
    ' Sélectionner la cellule B3 de la feuille Qualite
    ThisWorkbook.Worksheets("Qualite").Activate
    subFolderName = [E1]
 
    ' Ouvrir l'application Outlook
    Set outlookApp = New Outlook.Application
    ' Accéder à la boîte de réception
    Set outlookFolder = outlookApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
 
    N = 0
 
    For Each lastMessage In outlookFolder.items
 
'        If lastMessage.Subject Like "Nouveau controle*" Then
        If lastMessage.SenderName = "qualite@test.com" _
        And lastMessage.Subject Like "Nouveau controle*" Then
            If N > 0 Then If MsgBox("Un autre Message existe ,continuer ?", vbQuestion + vbOKCancel) = vbCancel Then Exit For
            Rows("3:" & Rows.Count).ClearContents
            With New MSForms.DataObject
                .SetText lastMessage.HTMLBody
                .PutInClipboard
            End With
            [B3].PasteSpecial
            Columns("B:C").AutoFit
            [E1].Select
' -------------------------------------------------------------------------------------------------------
'            Décommenter les lignes suivantes pour déplacer le mail

'            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
' -------------------------------------------------------------------------------------------------------

            N = N + 1
        End If
    Next
    MsgBox "Fin de la sub d'extraction" & vbLf & N & " mail(s) traité(s)"
 
End Sub

Microsoft 365 Extraction contenu mail outlook vers excel

raf26

XLDnaute Occasionnel

fanch55

fanch55

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

Pièces jointes

fanch55

XLDnaute Barbatruc

Pièces jointes

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

raf26

XLDnaute Occasionnel

raf26

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

fanch55

XLDnaute Barbatruc

Discussions similaires