Retourner des infos sur excel provenant d'un mail.

 '************* 1er BUG connu
'***** Résolution 1er BUG

 '******** Risque de 2ème BUG et
'ICI

Option Explicit

Dim Lien_Reception As HTMLAnchorElement
Dim Lien_Msgs_Prec As HTMLAnchorElement
Dim Tb()
Dim TableMsgs As HTMLTable
Dim Identifier_Mail As String

'**************************************************

Sub Import_Mails_De_Gmail()
Dim IE As New InternetExplorer
Dim IEDoc As HTMLDocument
Dim i As Integer

   Do
      Identifier_Mail = InputBox("Saisir un point commun pour identifier vos mails : ", "Correspondance dans la seconde colonne de Gmail")
   Loop While Identifier_Mail = ""
   'Insertion d'une nouvelle feuille
   Call Ajoute_Feuille
   'lance Internet Explorer
   IE.navigate "https://mail.google.com/"
   IE.Visible = True
   WaitIE IE
   Set IEDoc = IE.document
   If Not IEDoc.URL Like "*" & "inbox" & "*" Then Call Connecte(IEDoc)
   WaitIE IE
   Set IEDoc = IE.document
   'Affichage html
   Call AffichageHTML(IEDoc)
   WaitIE IE
   Set IEDoc = IE.document
   'recherche du lien vers boite de réception
   Call Lien_Boite_Reception(IEDoc)
   'recherche du lien vers les mails précédents
   Call Lien_Precedents(IEDoc)
   'cible la table contenant les emails
   Call Cibler_Table_Msgs(IEDoc) '************* 1er BUG connu
   'boucle sur les éléments de cette table et remplit le tableau des liens
   If Not TableMsgs Is Nothing Then
      Call Collect_Emails(TableMsgs)
   Else
      MsgBox "Bug. Veuillez recommencer"  '***** Résolution 1er BUG
      IE.Quit
      Set IE = Nothing
      Exit Sub
   End If
   'Restitution des données
   For i = LBound(Tb) To UBound(Tb)
      Cells(i + 1, 1) = Tb(i)
   Next
   IE.Quit
   Set IE = Nothing
End Sub

'**************************************************

Sub Ajoute_Feuille(Optional SertARien As Byte)
Dim strNewName As String, strCara As String, NouvelleFeuille As Boolean

Do
   NouvelleFeuille = True
   strNewName = InputBox("Nom de la nouvelle feuille : ", "Saisir un nom de feuille valide")
   If Len(strNewName) = 0 Then NouvelleFeuille = False
   If Valid_Name(strNewName, strCara) = False Then
      MsgBox "Le nom : " & strNewName & " est invalide." & vbCrLf & _
            "Un nom de feuille ne peut pas contenir le caractère : " & strCara, vbCritical
      NouvelleFeuille = False
   Else
   End If
   If Feuil_Exist(ThisWorkbook.Name, strNewName) = True Then
      MsgBox "Le nom : " & strNewName & " est invalide." & vbCrLf & _
            "Ce nom de feuille est déjà utilisé dans ce classeur.", vbCritical
      NouvelleFeuille = False
   End If
   If NouvelleFeuille = True Then Exit Do
Loop
ThisWorkbook.Sheets.Add
ActiveSheet.Name = strNewName
End Sub

'**************************************************

'Test si la chaine contient un caractère à éviter
Function Valid_Name(strName As String, strChr As String) As Boolean
Dim i As Byte, Tb_Car() As String, strProhib As String

strProhib = "/\:*?""<>|" ' Liste des caractères à éviter
Tb_Car = Split(StrConv(strProhib, vbUnicode), Chr$(0))
'Boucle sur tous les caractères à éviter
 'Nota : le -1 est dû au Split de la chaine par le séparateur Chr(0)
 'En effet, la chaine se terminant par un Chr(0) il convient d'exclure ce dernier caractère
For i = LBound(Tb_Car) To UBound(Tb_Car) - 1
    'Test si la chaîne contient un caractère prohibé
    If InStr(strName, Tb_Car(i)) > 0 Then
 'Si oui : Return False
        Valid_Name = False
 'ET Retourne le caractère prohibé
        strChr = Tb_Car(i)
        Exit Function
    End If
Next i
'Si OK : Return True
Valid_Name = True
End Function

'**************************************************

'Test si la feuille existe déjà
Function Feuil_Exist(strWbk As String, strWsh As String) As Boolean

'Gestionnaire d'erreur
On Error Resume Next
    '"Test"
    Feuil_Exist = (Workbooks(strWbk).Sheets(strWsh).Name = strWsh)
End Function

'**************************************************

Sub WaitIE(IE As InternetExplorer)
   'On boucle tant que la page n'est pas totalement chargée
   Do Until IE.ReadyState = READYSTATE_COMPLETE
      DoEvents
   Loop
End Sub

'**************************************************

Sub Connecte(Doc As HTMLDocument)
   Dim eMailAdress As String, PassWord As String
   Dim InputMail As HTMLInputElement, InputPass As HTMLInputElement
   Dim InputCookie As HTMLInputElement, InputSubmit As HTMLInputElement
   
   Do
      eMailAdress = InputBox("Adresse e-mail : ", "Saisir votre adresse mail")
   Loop While eMailAdress = ""
   Do
      PassWord = InputBox("Mot de passe : ", "Saisir votre mot de passe")
   Loop While PassWord = ""
   
   Set InputMail = Doc.getElementById("Email") 'Saisie adresse email
   InputMail.Value = eMailAdress
   Set InputPass = Doc.getElementById("Passwd") 'Saisie Mot de passe
   InputPass.Value = PassWord
   Set InputCookie = Doc.getElementById("PersistentCookie") 'Décoche "Rester connecté"
   If InputCookie.Value = "yes" Then InputCookie.Click
   Set InputSubmit = Doc.getElementById("signIn") 'Clic sur Connexion
   InputSubmit.Click
End Sub

'**************************************************

Sub AffichageHTML(Doc As HTMLDocument) '******** Risque de 2ème BUG
Dim maColl As IHTMLElementCollection, Elem As HTMLInputElement
   Set maColl = Doc.getElementsByTagName("input")
   For Each Elem In maColl
      'ICI
      If Elem.Value = "Affichage HTML simplifié" And Elem.className = "submit_as_link" Then Elem.Click: Exit For
   Next
End Sub

'**************************************************

Sub Lien_Boite_Reception(Doc As HTMLDocument) '******** Risque de 2ème BUG
Dim maColl As IHTMLElementCollection, Lien As HTMLAnchorElement

   Set maColl = Doc.getElementsByTagName("a")
   For Each Lien In maColl
      'ICI
      If Lien.innerText Like "*" & "Boîte de réception" & "*" Then Set Lien_Reception = Lien: Exit For
   Next
End Sub

'**************************************************

Sub Lien_Precedents(Doc As HTMLDocument) '******** Risque de 2ème BUG
Dim maColl As IHTMLElementCollection, Lien As HTMLAnchorElement

   Set maColl = Doc.getElementsByTagName("a")
   For Each Lien In maColl
      'ICI
      If Lien.innerText Like "Précédents" & "*" Then Set Lien_Msgs_Prec = Lien: Exit For
   Next
End Sub

'**************************************************

Sub Cibler_Table_Msgs(Doc As HTMLDocument) '******** Risque de 2ème BUG
Dim maColl As IHTMLElementCollection, Tabl As HTMLTable
   
   Set maColl = Doc.getElementsByTagName("table")
   For Each Tabl In maColl
      'ICI
      If Tabl.className = "th" Then Set TableMsgs = Tabl: Exit For
   Next
End Sub

'**************************************************

Sub Collect_Emails(maTable As HTMLTable) '******** Risque de 2ème BUG
'Collecte le contenu des mails "intéressants"
    Dim IE_2 As New InternetExplorer
    Dim IEDoc_2 As HTMLDocument
    Dim CollecLiens As IHTMLElementCollection, TbLiens()
    Dim CollecTR As IHTMLElementCollection, TD As HTMLGenericElement
    Dim CollecDiv As IHTMLElementCollection, Div As HTMLGenericElement
    Dim Elem As HTMLAnchorElement, Element As HTMLGenericElement, Enfant As HTMLGenericElement
    Dim i As Integer, j As Integer, Flag As Boolean
    
    Flag = False
    Set CollecLiens = maTable.getElementsByTagName("a")
    For Each Elem In CollecLiens
        ReDim Preserve TbLiens(i)
        Set TbLiens(i) = Elem
        i = i + 1
    Next
    i = 0
    Set CollecTR = maTable.getElementsByTagName("tr")
    For Each Element In CollecTR
       For Each TD In Element.Children
          If Flag = True Then
             IE_2.navigate TbLiens(i).href
             IE_2.Visible = True
             Flag = False
             Set IEDoc_2 = IE_2.document
             Set CollecDiv = IEDoc_2.getElementsByTagName("div")
             For Each Div In CollecDiv
                 If Div.className = "msg" Then 'ICI
                    For Each Enfant In Div.Children
                       ReDim Preserve Tb(j)
                       Tb(j) = Enfant.innerText
                       j = j + 1
                    Next Enfant
                 End If
             Next Div
          End If
          If TD.innerText = "*" & Identifier_Mail & "*" Then Flag = True
       Next TD
       i = i + 1
    Next Element
   IE_2.Quit
   Set IE_2 = Nothing
   Set IEDoc_2 = Nothing
End Sub

Option Explicit

'Sources : Ces 6 lignes sont à conserver dans votre fichier
    'http://www.commentcamarche.net/forum/affich-31378101-retourner-des-infos-sur-excel-provenant-d-un-mail
    'http://www.commentcamarche.net/faq/41759-vba-ajouter-copier-une-feuille-dans-un-classeur#les-fonctions-de-verification
    'http://www.commentcamarche.net/faq/41585-vba-inputbox
    'http://qwazerty.developpez.com/tutoriels/vba/ie-et-vba-excel/
    'http://www.developpez.net/forums/d1192897-4/logiciels/microsoft-office/excel/contribuez/article-manipulation-d-internet-explorer-via-vba/

'********************************* Déclaration des variables publiques
Dim IE As New InternetExplorer
Dim IEDoc As HTMLDocument
Dim Lien_Msgs_Prec As HTMLAnchorElement
Dim Tb()
Dim TableMsgs As HTMLTable
Dim Identifier_Mail As String

'********************************* Sub Principale
Sub Import_Mails_De_Gmail()
Dim CollLink As IHTMLElementCollection, CollInput As IHTMLElementCollection, CollTable As IHTMLElementCollection
Dim i As Integer

   Do
      Identifier_Mail = InputBox("Saisir un point commun pour identifier vos mails : ", "Correspondance dans la seconde colonne de Gmail")
   Loop While Identifier_Mail = ""
   
   'Insertion d'une nouvelle feuille
   Call Ajoute_Feuille
   
   'lance Internet Explorer
   IE.navigate "https://mail.google.com/"
   IE.Visible = True
   WaitIE IE
   Set IEDoc = IE.document
   WaitDoc IEDoc
   
   'connexion (au cas ou) au compte gmail
   If Not IEDoc.URL Like "*" & "inbox" & "*" Then Call Connecte(IEDoc)
   WaitIE IE
   Set IEDoc = IE.document
   WaitDoc IEDoc
   
   'Affichage html
   Set CollInput = IEDoc.getElementsByTagName("input")
   If Not CollInput Is Nothing Then
      AffichageHTML CollInput
   Else
      Erreur "Collection des liens pour affichage HTML vide"
      Exit Sub
   End If
   WaitIE IE
   Set IEDoc = IE.document
   WaitDoc IEDoc
   Do
      'recherche du lien vers les mails précédents
      Set CollLink = IEDoc.getElementsByTagName("a")
      If Not CollLink Is Nothing Then
         Lien_Precedents CollLink
      Else
         Erreur "Collection des Liens, pour accès mails précédents, vide"
         Exit Sub
      End If
   
      'cible la table contenant les emails
      Set CollTable = IEDoc.getElementsByTagName("table")
      If Not CollTable Is Nothing Then
         Cibler_Table_Msgs CollTable
      Else
         Erreur "Collection des tables contenant les emails vide"
         Exit Sub
      End If
      'boucle sur les éléments de cette table et remplit le tableau des liens
      If Not TableMsgs Is Nothing Then
         Collect_Emails TableMsgs
      Else
         Erreur "Collection des liens (liste des emails) vide"
         Exit Sub
      End If
      'Clic sur le lien "Précédents>" ou sort de la boucle
      If Lien_Msgs_Prec Is Nothing Then
         Exit Do
      Else
         Lien_Msgs_Prec.Click
         Set IEDoc = IE.document
         WaitDoc IEDoc
      End If
   Loop
   IE.Quit
   Set IE = Nothing
   Set IEDoc = Nothing
   'Restitution des données
   For i = LBound(Tb) To UBound(Tb)
      Cells(i + 1, 1) = Tb(i)
   Next
   Columns("A").AutoFit
   MsgBox "Import terminé"
End Sub

'********************************* Traitement d'erreur
Sub Erreur(Texte As String)

MsgBox "Bug à corriger :" & vbCrLf & Texte
IE.Quit
Set IE = Nothing
Set IEDoc = Nothing
End Sub

'********************************* Attente chargement complet de la page Internet Explorer
Sub WaitIE(IE As InternetExplorer)

   Do Until IE.readyState = READYSTATE_COMPLETE
      DoEvents
   Loop
End Sub

'********************************* Attente chargement complet du document (contenu de la page IE)
Sub WaitDoc(doc As HTMLDocument)

  Do While Not doc.readyState = "complete"
    DoEvents
  Loop
End Sub

'********************************* Ajoute la nouvelle feuille pour accueillir les données des mails
Sub Ajoute_Feuille(Optional NouvelleFeuille As Boolean)
Dim strNewName As String, strCara As String

Do
   NouvelleFeuille = True
   strNewName = InputBox("Nom de la nouvelle feuille : ", "Saisir un nom de feuille valide")
   If Len(strNewName) = 0 Then NouvelleFeuille = False
   If Valid_Name(strNewName, strCara) = False Then
      MsgBox "Le nom : " & strNewName & " est invalide." & vbCrLf & _
            "Un nom de feuille ne peut pas contenir le caractère : " & strCara, vbCritical
      NouvelleFeuille = False
   Else
   End If
   If Feuil_Exist(ThisWorkbook.Name, strNewName) = True Then
      MsgBox "Le nom : " & strNewName & " est invalide." & vbCrLf & _
            "Ce nom de feuille est déjà utilisé dans ce classeur.", vbCritical
      NouvelleFeuille = False
   End If
   If NouvelleFeuille = True Then Exit Do
Loop
ThisWorkbook.Sheets.Add
ActiveSheet.Name = strNewName
End Sub

'********************************* Fonction de vérification pour ajout feuille
'Test si la chaine (nom de la future feuille) contient un caractère à éviter
Function Valid_Name(strName As String, strChr As String) As Boolean
Dim i As Byte
Dim Tb_Car() As String
Dim strProhib As String

strProhib = "/\:*?""<>|"
Tb_Car = Split(StrConv(strProhib, vbUnicode), Chr$(0))
For i = LBound(Tb_Car) To UBound(Tb_Car) - 1
    If InStr(strName, Tb_Car(i)) > 0 Then
        Valid_Name = False
        strChr = Tb_Car(i)
        Exit Function
    End If
Next i
Valid_Name = True
End Function

'********************************* Fonction de vérification pour ajout feuille
'Test si la feuille existe déjà
Function Feuil_Exist(strWbk As String, strWsh As String) As Boolean

   On Error Resume Next
   Feuil_Exist = (Workbooks(strWbk).Sheets(strWsh).Name = strWsh)
End Function

'********************************* Connexion au compte Gmail
Sub Connecte(doc As HTMLDocument)
Dim eMailAdress As String, PassWord As String
Dim InputMail As HTMLInputElement, InputPass As HTMLInputElement
Dim InputCookie As HTMLInputElement, InputSubmit As HTMLInputElement
   
   Do
      eMailAdress = InputBox("Adresse e-mail : ", "Saisir votre adresse mail")
   Loop While eMailAdress = ""
   Do
      PassWord = InputBox("Mot de passe : ", "Saisir votre mot de passe")
   Loop While PassWord = ""
   
   Set InputMail = doc.getElementById("Email") 'Saisie adresse email
   InputMail.Value = eMailAdress
   Set InputPass = doc.getElementById("Passwd") 'Saisie Mot de passe
   InputPass.Value = PassWord
   Set InputCookie = doc.getElementById("PersistentCookie") 'Décoche "Rester connecté"
   If InputCookie.Value = "yes" Then InputCookie.Click
   Set InputSubmit = doc.getElementById("signIn") 'Clic sur Connexion
   InputSubmit.Click
End Sub

'********************************* Affiche la page Gmail en affichage HTML (évite les 3 onglets "Principale", "Réseaux sociaux", "Promotions")
Sub AffichageHTML(CollI As IHTMLElementCollection)
Dim Elem As HTMLInputElement

   For Each Elem In CollI
      If Elem.Value = "Affichage HTML simplifié" And Elem.className = "submit_as_link" Then Elem.Click: Exit For
   Next
End Sub

'********************************* Enregistre le lien vers les mails précédents (si plusieurs pages de mails)
Sub Lien_Precedents(CollLiens As IHTMLElementCollection)
Dim Lien As HTMLAnchorElement

   For Each Lien In CollLiens
      If Lien.innerText Like "Précédents" & "*" Then Set Lien_Msgs_Prec = Lien: Exit For
   Next
End Sub

'********************************* Cible la table contenant les liens vers chaque email
Sub Cibler_Table_Msgs(CollT As IHTMLElementCollection)
Dim Tabl As HTMLTable

   For Each Tabl In CollT
      If Tabl.className = "th" Then Set TableMsgs = Tabl: Exit For
   Next
End Sub

'********************************* Ouvre les mails dans une nouvelle page IE et récupère leur contenu
Sub Collect_Emails(maTable As HTMLTable)
'Collecte tous les liens vers les mails "intéressants"
Dim IE_2 As New InternetExplorer
Dim IEDoc_2 As HTMLDocument
Dim CollecLiens As IHTMLElementCollection, CollecTR As IHTMLElementCollection, CollecDiv As IHTMLElementCollection
Dim TD As HTMLGenericElement, Div As HTMLGenericElement, Element As HTMLGenericElement, Enfant As HTMLGenericElement
Dim Elem As HTMLAnchorElement
Dim TbLiens()
Dim i As Integer, j As Integer
Dim Flag As Boolean
    
    Flag = False
    Set CollecLiens = maTable.getElementsByTagName("a")
    For Each Elem In CollecLiens
        ReDim Preserve TbLiens(i)
        Set TbLiens(i) = Elem
        i = i + 1
    Next
    i = 0
    Set CollecTR = maTable.getElementsByTagName("tr")
    For Each Element In CollecTR
       For Each TD In Element.Children
          If Flag = True Then
             IE_2.navigate TbLiens(i).href
             IE_2.Visible = True
             WaitIE IE_2
             Flag = False
             Set IEDoc_2 = IE_2.document
             WaitDoc IEDoc_2
             Set CollecDiv = IEDoc_2.getElementsByTagName("div")
             For Each Div In CollecDiv
                 If Div.className = "msg" Then
                    For Each Enfant In Div.Children
                       ReDim Preserve Tb(j)
                       Tb(j) = Enfant.innerText
                       j = j + 1
                    Next
                 End If
             Next
          End If
          If TD.innerText Like "*" & Identifier_Mail & "*" Then Flag = True
       Next TD
       i = i + 1
    Next Element
   IE_2.Quit
   Set IE_2 = Nothing
   Set IEDoc_2 = Nothing
End Sub