Extraction d'informations d'un mail Outlook vers un fichier Excel | VBA

Bonjour à tous,

C'est mon premier post donc soyez indulgent :)

Je débute dans la programmation VBA mais j'ai été affecté d'un projet au sein de la cellule statistiques mon entreprise pour une automatiser la tâche de notre équipe de gestionnaire.

Voici ma mission : Notre équipe de gestionnaires reçois régulièrement et par grandes quantités des mails d'un même destinataire. ces mails contiennent certaines informations que nos gestionnaires devront extraire et retranscrire à la main dans d'autres de nos logiciels. De plus, ces mails ont tous le même format, juste certaines informations diffèrent comme les noms et prénoms des clients, les numéros de téléphone etc.

Ma mission est de créer une macro VBA qui parcourra la boîte mail sur laquelle les gestionnaires reçoivent ces mail et pour chaque mail, automatiser l'extraction des informations dont les gestionnaires ont besoin vers un fichier Excel. De ce fait, nos gestionnaires pourront plus facilement avoir accès aux données dont ils ont besoin ce qui réduira leur temps de traitement d'un mail.

Voici mon problème :

Mon problème est que je n'arrive pas à extraire l'une des informations des mail. Tout d'abord, la méthode que j'ai instauré dans mon code VBA pour extraire les informations est très simple : Je définis un groupe de mots (que l'on appellera groupe de mots clé) et le mot à extraire sera le mot suivant ce groupe de mots. Par exemple dans la phrase "Bonjour je m'appelle Jean et j'ai 33 ans" si je définis mon groupe de mots clés comme étant "Bonjour je m'appelle", le mot à extraire sera alors "Jean".

Néanmoins lorsque j'utilise cette méthode pour extraire un mot se trouvant un saut de ligne après mon groupe de mots clés, la macro n'extrait aucun mot. j'ai essayé (à l'aide de Chat GPT) de spécifier que la macro devait faire abstraction des espaces ou des sauts de ligne mais toujours rien. je me tourne donc vers comme ultime recours. Je vous joins une image du mail avec une flèche rouge indiquant le mot que je souhaite extraire et une accolade indiquant le groupe de mots clés. J'espère que mes explications sont claires, je vous joins également mon code VBA. N'hésitez pas à me proposer d'autres alternatives d'extraction de ce informations si vous les jugez pertinentes ou plus simples, je suis preneur.

Merci d'avance,

Bien cordialement, Samuel

Sub outlook_import_emailbody()

    Dim o As Outlook.Application
    Set o = New Outlook.Application
    Dim ons As Outlook.Namespace
    Set ons = o.GetNamespace("MAPI")

    ' Remplacez "Test" par le nom exact du sous-dossier que vous souhaitez traiter
    Dim MYFOL As Outlook.Folder
    Set MYFOL = ons.GetDefaultFolder(olFolderInbox).Folders("Test")

    Dim omail As Outlook.MailItem
    Dim R As Long
    R = 4

    Dim bodyText As String

    ' Boucle pour parcourir les e-mails et extraire les informations requises
    For Each omail In MYFOL.Items
        ' Vérifier si l'objet de l'e-mail est "Objet test | pour des raisons de confidentialité "
        If omail.Subject = "Objet test | pour des raisons de confidentialité " Then
            Cells(R, 1).Value = omail.Subject
            Cells(R, 2).Value = omail.ReceivedTime
            Cells(R, 3).Value = omail.SenderEmailAddress

            ' Extraire les caractères à partir des mots-clés spécifiés
            bodyText = omail.Body

            ' Recherche du mot-clé "la livraison de votre véhicule immatriculé"
            Dim immatriculationKey As String
            immatriculationKey = "La livraison de votre véhicule immatriculé"
            Dim immatriculationStart As Long
            immatriculationStart = InStr(1, bodyText, immatriculationKey)

            If immatriculationStart > 0 Then
                immatriculationStart = immatriculationStart + Len(immatriculationKey) + 1 ' Pour commencer après le mot-clé
                Dim immatriculationEnd As Long
                immatriculationEnd = InStr(immatriculationStart, bodyText, " ")
                If immatriculationEnd > 0 Then
                    Dim extractedImmatriculation As String
                    extractedImmatriculation = Mid(bodyText, immatriculationStart, immatriculationEnd - immatriculationStart)
                    Cells(R, 4).Value = extractedImmatriculation
                End If
            End If

            ' Recherche du mot-clé "dans les 72h suivants ce message à l'adresse"
            Dim collaborateurKey As String
            collaborateurKey = "dans les 72h suivants ce message à l'adresse"
            Dim collaborateurStart As Long
            collaborateurStart = InStr(1, bodyText, collaborateurKey)

            If collaborateurStart > 0 Then
                collaborateurStart = collaborateurStart + Len(collaborateurKey) + 1 ' Pour commencer après le mot-clé

                ' Ignorer tous les caractères non alphabétiques pour obtenir le prochain mot
                Dim extractedCollaborateur As String
                Do While collaborateurStart <= Len(bodyText)
                    Dim char As String
                    char = Mid(bodyText, collaborateurStart, 1)

                    If Not char Like "[A-Za-z]" Then
                        Exit Do
                    End If

                    extractedCollaborateur = extractedCollaborateur & char
                    collaborateurStart = collaborateurStart + 1
                Loop

                Cells(R, 5).Value = Trim(extractedCollaborateur) ' Utilisez la fonction Trim pour supprimer les espaces supplémentaires avant et après le nom
            End If

            R = R + 1

        End If
    Next omail

    Set o = Nothing
    Set ons = Nothing
    Set MYFOL = Nothing
    Set omail = Nothing
End Sub

Voici l'image du mail :

Bonjour,

Si vous pensez que c'est le saut de ligne qui pose problème, une solution peut être de tous les supprimer avec VBA,

bodyText = Replace(bodyText, Chr(10), "") 'retirer les sauts de ligne
bodyText = Replace(bodyText, Chr(13), "") 'retirer les retours chariot

Ils sont pratiques pour l'oeil humain car ça rend les choses plus lisibles, mais pour les machines ce n'est pas très utile. Leur code ASCII sont respectivement 10 et 13.

J'espère que ça règlera votre problème

bonjour Ausecours,sametbas,

pour le véhicule immatriculé

 
 sp = Split(bodyText, "La livraison de votre véhicule immatriculé")     'diviser le bodytext text sur cette chaine
 If UBound(sp) >= 1 Then       'la chaine existe et il y a au minimum 2 sous-chaines
    Cells(R, 4).Value = Split(Trim(sp(1)))(0)     '1ier mot de la 2ième sous-chaine
 End If

pour l'autre texte (vblf, vbcrlf ???)

sp = Split(bodyText, "dans les 72h suivants ce message à l'adresse")     'diviser le bodytext text sur cette chaine
If UBound(sp) >= 1 Then       'la chaine existe et il y a au minimum 2 sous-chaines
   sp1 = Split(sp(1), "en cas de non réception") 'diviser la 2ième sous-chaine sur "en cas de ... "
   If UBound(sp1) > 0 Then
      sp2 = Split(sp1(0), vbLf)     'diviser l'adresse en plusieurs sous-chaines
   End If
End If

Bonjour,

Tout d'abord merci pour vos réponses. Ausecour lorsque j'ai vu votre retour j'ai trouvé que cétait une bonne idée, j'ai alors retravaillé mon code en retirant les sauts de ligne et les retours à la ligne. Voici mon code :

Sub outlook_extract_email_body()

    Dim o As Outlook.Application
    Set o = New Outlook.Application
    Dim ons As Outlook.Namespace
    Set ons = o.GetNamespace("MAPI")

    ' Remplacez "Test" par le nom exact du sous-dossier que vous souhaitez traiter
    Dim MYFOL As Outlook.Folder
    Set MYFOL = ons.GetDefaultFolder(olFolderInbox).Folders("Test")

    Dim omail As Outlook.MailItem
    Dim R As Long
    R = 4

    Dim bodyText As String
    Dim extractedBody As String ' Variable pour stocker le corps du mail sans les sauts de ligne et les retours à la ligne

    ' Boucle pour parcourir les e-mails et extraire les informations requises
    For Each omail In MYFOL.Items
        ' Vérifier si l'objet de l'e-mail est "..........."
        If omail.Subject = "........." Then
            Cells(R, 1).Value = omail.Subject
            Cells(R, 2).Value = omail.ReceivedTime
            Cells(R, 3).Value = omail.SenderEmailAddress

            ' Extraire le corps du mail sans les sauts de ligne et les retours à la ligne
            bodyText = omail.Body
            extractedBody = Replace(bodyText, Chr(10), " ") ' Remplacer les sauts de ligne par un espace
            extractedBody = Replace(extractedBody, Chr(13), " ") ' Remplacer les retours à la ligne par un espace

            ' Afficher le corps du mail sans les sauts de ligne et les retours à la ligne dans la cellule
            Cells(R, 4).Value = extractedBody

            ' Recherche du mot-clé "dans les 72h suivants ce message à l’adresse"
            Dim livraisonKey As String
            livraisonKey = "dans les 72h suivants ce message à l’adresse         "
            Dim livraisonStart As Long
            livraisonStart = InStr(1, extractedBody, livraisonKey)

            If livraisonStart > 0 Then
                livraisonStart = livraisonStart + Len(livraisonKey) + 1 ' Pour commencer après le mot-clé
                Dim livraisonEnd As Long
                livraisonEnd = InStr(livraisonStart, extractedBody, " ")
                If livraisonEnd > 0 Then
                    Dim extractedLivraison As String
                    extractedLivraison = Mid(extractedBody, livraisonStart, livraisonEnd - livraisonStart)
                    Cells(R, 5).Value = extractedLivraison
                End If
            End If

            ' Recherche du mot-clé "dans les 72h"
            Dim dansLes72hKey As String
            dansLes72hKey = "dans les 72h"
            Dim dansLes72hStart As Long
            dansLes72hStart = InStr(1, extractedBody, dansLes72hKey)

            If dansLes72hStart > 0 Then
                dansLes72hStart = dansLes72hStart + Len(dansLes72hKey) + 1 ' Pour commencer après le mot-clé
                Dim dansLes72hEnd As Long
                dansLes72hEnd = InStr(dansLes72hStart, extractedBody, " ")
                If dansLes72hEnd > 0 Then
                    Dim extractedDansLes72h As String
                    extractedDansLes72h = Mid(extractedBody, dansLes72hStart, dansLes72hEnd - dansLes72hStart)
                    Cells(R, 6).Value = extractedDansLes72h
                End If
            End If

            R = R + 1

        End If
    Next omail

    Set o = Nothing
    Set ons = Nothing
    Set MYFOL = Nothing
    Set omail = Nothing
End Sub

je n'ai pas eu le temps de le tester car je suis directement parti en réunion mais je vous triendrai au courant. Si cela ne focntionne pas je vais alors essayer de résoudre mon problème avec les codes de BsAlv. En, tout cas merci messieurs