XL 2010 Explorer un mail (outlook) via vba excel - précisions

Bulr6 · 14 Juin 2017

Bonjour à tous,
J'ai créer (en m'inspirant énormément de ce post https://forum.excel-pratique.com/excel/recuperer-les-informations-d-un-mail-t30977.html ). Malheureusement, mon code pêche par moment et je n'arrive pas à comprendre ce qui lui pose problème.
1er problème : il faut impérativement qu'outlook soit "ouvert" ... pourtant mon instruction lance outlook en arrière plan ... ça je le vois ... mais ne fait rien
2e problème : quand j'active ma macro le premier mail est traité et les suivant recopie les informations du premier à partir de cette ligne

Code:

dejafait = True
        For compt = 0 To UBound(mybody)
            If InStr(1, UCase(mybody(compt)), UCase("Code Barre utilisateur ")) Then
                CBlecteur = LTrim(Split(mybody(compt), ":")(1))
                dejafait = False

3e problème : bizarrement quand je marque manuellement les mais en "non lu" et que je relance la macro celle ci les lit normalement et sus correctement les instructions.

J'espère vraiment que certains pourront me guider pour la modification de cette commande pour mieux comprendre les mails sont sous cette forme :

Code Barre utilisateur : "12345" ou "12345678"
Localisation courrante : **********
Lieu de retrait : ********
Code Barre Exemplaire : 123456
Titre : VBA pour les nuls
Auteur : excel-download
Cote : *******
Ce lien n'existe plus

N de lecteur : "12345" ou "12345678"
Nom : Mr Jean BOMBEUR
Date de naissance : 1111-11-11
Adresse : 10 rue de la soif
Mel : a aaaaaaa@bbbbbb.ccc

Et pour finir voici mon code :

Code:

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("aaaaaaaaaaaaaa@bbbbbb.ccc").Folders("Boîte de réception")

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

If i.UnRead = True Then
    If i.SenderEmailAddress = "toujours@la.même" And i.Subject Like ("*disponible*") 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("Code Barre utilisateur ")) Then
                CBlecteur = LTrim(Split(mybody(compt), ":")(1))
                dejafait = False
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Localisation courrante ")) > 0 Then
                Localisation = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Lieu de retrait")) > 0 Then
                retrait = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Code Barre Exemplaire")) > 0 Then
                codebarre = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Titre")) > 0 Then
                titre = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Auteur")) > 0 Then
                auteur = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Cote")) > 0 Then
                cote = LTrim(Split(mybody(compt), ":")(1))
            End If
         
            If InStr(1, UCase(mybody(compt)), UCase("Nom")) > 0 Then
                lecteur = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Téléphone")) > 0 Then
                tél = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("HYPERLINK")) > 0 Then
                desti = LTrim(Split(mybody(compt), """")(2))
            End If
         
        Next
     
        Sheets(1).Range(Cells(Ligne, 1), Cells(Ligne, 14)).Borders.Value = 1
        Sheets(1).Cells(Ligne, 13).Interior.Color = RGB(209, 209, 209)
        Sheets(1).Cells(Ligne, 1) = sujet
        Sheets(1).Cells(Ligne, 2) = dateM
        Sheets(1).Cells(Ligne, 3) = CBlecteur
        Sheets(1).Cells(Ligne, 6) = lecteur
        Sheets(1).Cells(Ligne, 4) = tél
        Sheets(1).Cells(Ligne, 5) = desti
        Sheets(1).Cells(Ligne, 12) = retrait
        Sheets(1).Cells(Ligne, 11) = codebarre & "0390"
        Sheets(1).Cells(Ligne, 7) = titre
        Sheets(1).Cells(Ligne, 8) = auteur
        Sheets(1).Cells(Ligne, 9) = cote
        Sheets(1).Cells(Ligne, 10) = Localisation
        Sheets(1).Cells(Ligne, 13).Font.Name = "Wingdings"
        Sheets(1).Cells(Ligne, 13) = "¨"
        Sheets(1).Cells(Ligne, 15) = DateAdd("d", 7, DateT)
        i.UnRead = False
  Else
     If i.SenderEmailAddress = "toujours@la.même" And i.Subject Like ("*Annulation*") Then
        chaine = i.Subject
       mybody = Split(i.Body, vbCrLf)
        fromsender = i.SenderEmailAddress
        dateM = i.CreationTime
        For compt = 0 To UBound(mybody)
            If InStr(1, UCase(mybody(compt)), UCase("Code Barre utilisateur ")) Then
                CBlecteur = LTrim(Split(mybody(compt), ":")(1))
            End If
            If InStr(1, UCase(mybody(compt)), UCase("Code Barre Exemplaire")) > 0 Then
                codebarre = LTrim(Split(mybody(compt), ":")(1))
            End If
       
        Next
     
        Sheets(1).Range(Cells(Ligne, 1), Cells(Ligne, 14)).Borders.Value = 1
        Sheets(1).Cells(Ligne, 13).Interior.Color = RGB(209, 209, 209)
        Sheets(1).Cells(Ligne, 1) = sujet
        Sheets(1).Cells(Ligne, 2) = dateM
        Sheets(1).Cells(Ligne, 3) = CBlecteur
        Sheets(1).Cells(Ligne, 11) = codebarre & "0390"
        Sheets(1).Cells(Ligne, 13).Font.Name = "Wingdings"
        Sheets(1).Cells(Ligne, 13) = "¨"
        Sheets(1).Cells(Ligne, 15) = DateAdd("d", 7, DateT)
        i.UnRead = False
     End If
  End If
End If

Next i

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

Est ce que j'ai oublié un élément dans la construction de mon code ? Une variable ou autre ? bref est ce qu'il est propre et d'où peuvent venir mes problèmes ?

Petites précisions : idéalement il faudrait prendre en compte qu'outlook est ouvert en parallèle.
En l'état actuel même si outlook est ouvert j'ai le problème au niveau de la lecture du contenu des mails.

Merci d'avance à ceux qui prendront le temps de se pencher sur mon problème.

Bulr6 · 15 Juin 2017

Alors globalement apres plusieurs tests ... le problème est que ma macro n'arrive pas à récupérer le corps des nouveaux mails entrant.
Ce problème semble se resoudre quand je synchronise tous les dossiers ... "envoyer et recevoir" sur outlook mais je ne sais pas comment insérer cette instruction
....
J'ai trouvé avec tout simplement un :

--------.GetNamespace("MAPI")
.SendAndReceive (True)
Maintenant si j'arrive à dire à la macro d'attendre la fin de ce sendandreceive je pourrais finir mes tests

XL 2010 Explorer un mail (outlook) via vba excel - précisions

Bulr6

XLDnaute Nouveau

Bulr6

XLDnaute Nouveau

Discussions similaires