Lire contenu d'un email

Bonjour au forum,

Je cale sur un truc tout bête. Mais j'arrive pas à afficher dans ma feuille excel le même format que dans le mail.

Je m'explique:

Avec le code ci-dessous, j'arrive à faire apparaître les valeurs uniquement en lignes. J'arrive pas à aller en bout de ligne sauter la ligne et écrire la suivante. J'ai tout qui se place en colonne.

Bien entendu il s'agit des titres de mon email. J'ai en dessous les données correspondantes.

Alors qu'elles sont en colonnes puis retour à la ligne comme ceci dans le mail.

Sub LireMessages_dans_excel()
    Dim olApp As Object, NS As Object, Dossier As Object
    Dim DossierDest As Object, DossierCible As Object
    Dim i As Object
    Set olApp = CreateObject("Outlook.Application")
    Set NS = olApp.GetNamespace("MAPI")
    Set DossierSource = NS.GetDefaultFolder(olFolderInbox).Folders("source")
 With Sheets("Feuil1")
        For Each i In DossierSource.Items
                For x = 0 To UBound(Split(i.Body, vbCrLf))
                    Ligne = Ligne + 1
                    .Cells(Ligne, 2) = Split(i.Body, vbCrLf)(x)
                Next x
                Ligne = Ligne + 1
        Next i
    End With
    Set NS = Nothing
    Set olApp = Nothing

        MsgBox "terminé"

    Set NS = Nothing
    Set olApp = Nothing
End Sub

J'ai essayé avec une double boucle mais sans sucés.

Merci par avance.

Bonjour,

une possibilité à tester,

        For Each i In DossierSource.Items
                For x = 0 To UBound(Split(i.Body, vbCrLf))
                    Ligne = Ligne + 1
                    .Cells(Ligne, x + 2) = Split(i.Body, vbCrLf)(x)
                Next x
                Ligne = Ligne + 1
        Next i

Salut sabV,

Merci de ton aide, mais c'est pas concluant, ça fait un jolie escalier .

Les données sont en diagonales au lieu d’être en colonnes.

Mais j'ai essayé un autre code avec un array, beaucoup plus rapide (la boucle du code précedant prend 30 secondes pour lire 1 mail environ).

En revanche, toujours le même problème de résultat en colonnes.

Poste le code en arrray pour info.

Option Explicit
Sub EmailText()
    Dim ObjOutlook As Object
    Dim MyNamespace As Object
    Dim i As Integer
    Dim j As Long
    Dim abody() As String
    Application.ScreenUpdating = False
    Dim debut As Date
    Dim fin As Date
    Dim Duree As Date

debut = Time

     'Declare Variables
    Set ObjOutlook = GetObject(, "Outlook.Application")
     'Find the outlook application
    Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
     'Find the "NameSpace" -Current user environment from outlook
    For i = 1 To MyNamespace.GetDefaultFolder(6).Folders("source").Items.Count
         'loop through all the items in the temp folder, defaultfolder(6) is the inbox.
        abody = Split(MyNamespace.GetDefaultFolder(6).Folders("source").Items(i).Body, Chr(13) & Chr(10))
         'for each item, "split" the body of the email by linebreak into an array
        For j = 0 To UBound(abody)
             'For each item in the array (i.e. each line) add the line to the first empty cell in column A of sheet1
            Feuil2.Cells(65000, 1).End(xlUp).Offset(1, 0).Value = abody(j)
        Next
        MyNamespace.GetDefaultFolder(6).Folders("source").Items (i)

   Next
    Set ObjOutlook = Nothing
    Set MyNamespace = Nothing
     'Clear the object variables.  I don't think this is needed, but it's good practice.
fin = Time

Duree = fin - debut
MsgBox Duree

End Sub

bonjour,

il faut faire le changement de ligne une seul fois,

        For Each i In DossierSource.Items
                For x = 0 To UBound(Split(i.Body, vbCrLf))
                    .Cells(Ligne, x + 2) = Split(i.Body, vbCrLf)(x)
                Next x
                Ligne = Ligne + 1
        Next i

Hello,

C'est pas mieux... cela me place tout sur la même ligne.

J'ai trouvé une autre solution, je copie le tableau et coller en valeur.

ça fonctionne comme je souhaite.

En tout cas merci de ton aide.

Le code si ça intéresse des gens.

Sub GetFromInbox()

Dim objNS As Outlook.Namespace: Set objNS = GetNamespace("MAPI")
Dim olFolder As Outlook.MAPIFolder
Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set mysourcefolder = olFolder.Folders("source")
Dim item As Object
Dim wb As Workbook

Set wb = ThisWorkbook

For Each item In mysourcefolder.Items
    If TypeOf item Is Outlook.MailItem Then
        Dim oMail As Outlook.MailItem: Set oMail = item
          oMail.GetInspector().WordEditor.Range.FormattedText.Copy
           With Sheets("Feuil3")
           .Range("A1").PasteSpecial Paste:=xlPasteValues
           End With
    End If
Next

End Sub