Sub LireMessages()

Dim olapp As Outlook.Application
Dim NS As Object, Dossier As Object
Dim OlExp As Object
Dim i As Object
Dim mybody() As String
Dim fromsender As String
Dim Obj As OLEObject
Set olapp = CreateObject("Outlook.Application")
Set NS = olapp.GetNamespace("MAPI")
Set Dossier = NS.Folders("xxx@xx.com").Folders("Boîte de réception")

For Each i In Dossier.Items
Ligne = Sheets(TEST).[A65000].End(xlUp).Row + 1
DateT = Now()

If i.UnRead = True Then
    If i.SenderEmailAddress = "noreply@xxx.fr" Then '
        chaine = i.Subject
        mybody = Split(i.Body, vbCrLf)
        fromsender = i.SenderEmailAddress
        dateM = i.CreationTime
        dejafait = True
        For compt = 0 To UBound(mybody)
            If InStr(1, UCase(mybody(compt)), UCase("Origine de la souscription ")) Then
                Reseau = LTrim(Split(mybody(compt), ":")(1))
                dejafait = False
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Civilité ")) > 0 Then
                Civilité = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Nom ")) > 0 Then
                Nom = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Prénom ")) > 0 Then
                Prénom = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Tél ")) > 0 Then
                Tél = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Email ")) > 0 Then
                Email = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Adresse ")) > 0 Then
                Adresse = LTrim(Split(mybody(compt), ":")(1))
            End If
         
            If InStr(1, UCase(mybody(compt)), UCase("Code Postal ")) > 0 Then
                CP = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Ville ")) > 0 Then
                Ville = LTrim(Split(mybody(compt), ":")(1))
                End If
            If InStr(1, UCase(mybody(compt)), UCase("Rappel du motif ")) > 0 Then
                Motif = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Commentaire ")) > 0 Then
                Commentaire = LTrim(Split(mybody(compt), """")(2))
            End If
         
        Next
     
        Sheets(TEST).Range(Cells(Ligne, 1), Cells(Ligne, 16)).Borders.Value = 1
        Sheets(TEST).Cells(Ligne, 1) = sujet
        Sheets(TEST).Cells(Ligne, 2) = dateM
        Sheets(TEST).Cells(Ligne, 3) = Reseau
        Sheets(TEST).Cells(Ligne, 6) = Civilité
        Sheets(TEST).Cells(Ligne, 4) = Nom
        Sheets(TEST).Cells(Ligne, 5) = Prénom
        Sheets(TEST).Cells(Ligne, 12) = Tél
        Sheets(TEST).Cells(Ligne, 11) = Email
        Sheets(TEST).Cells(Ligne, 7) = titre
        Sheets(TEST).Cells(Ligne, 8) = auteur
        Sheets(TEST).Cells(Ligne, 9) = Adresse
        Sheets(TEST).Cells(Ligne, 10) = CP
        Sheets(TEST).Cells(Ligne, 13) = Ville
        Sheets(TEST).Cells(Ligne, 15) = Motif
        Sheets(TEST).Cells(Ligne, 16) = Commentaire
        i.UnRead = False
 
     End If
  End If


Next i

Set NS = Nothing
Set Dossier = Nothing
Set i = Nothing
End Sub