Faire une boucle sur un object d'une page HTML

Version imprimable

12/12/2023, 18h34
Eric_Hockey_Sub

1 pièce(s) jointe(s)

Faire une boucle sur un object d'une page HTML

Voici un nouveau problème sur lequel je bute depuis un moment.

Je prépare une application qui servira aux arbitres lors d'une compétitions et qui permettra de valider les joueurs en amont du match avec lesdocuments entièrement dématérialisés

Je dois relever des infos sur des joueurs pour que l'arbitre puisse valider celui-ci. J'ai mis en exemple en utilisant ma propre page de ma licence, afin de ne pas transmettre des infos sur des personnes autre que moi .

J'arrive à récupérer presque toutes les données que j'ai besoin et ma question est :

1) Comment récupérer la date de validité de l'assurance, puisque la licence utilise le même texte "Date de validité" ? Sous forme d'une boucle ?

2) Comment récuperer la partie "Nom prénom et date de naissance " sans devoir passer par la 2em macro (site_fede) afin d'éviter d'utiliser IE qui pourrait ne pas être présent sur tous les postes des futurs utilisateurs ( application finale sera utilisée par de multiples utilisateurs)

Je précise que cette application sera validée par la fédération (FFESSM) d’où les accès à ce site avec les éléments "clès" dans le lien

Merci à ceux qui voudront bien m'aider

1 pièce(s) jointe(s)

Hello,
pour simplifier les recherches des éléments avec l'objet COM HTMLFile il y a les fonctions de type queryselector . Par exemple avec ceci :

Code:

Set elems = htmlDoc.querySelectorAll("div.card-body > p")

je récupère tous les noeuds des balises div de classe card-body suivi de la balise p
et pour les extractions de chaînes utiliser les expressions régulières.
Avec ce code ( j'ai modifié les infos personnelles)

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
Sub WebsiteInfo()
Dim cheminWeb As Variant
Dim ws As Worksheet, regex As Object, matches As Object
Dim htmlDoc As Object, elems As Object, x As Integer
        Set ws = Worksheets("Feuil1")
        Set regex = CreateObject("VBScript.RegExp")
        ws.Range("D2:D18") = Empty
        On Error GoTo ErrWeb
        cheminWeb = "https://l.ffessm.fr/Home/InfoLicence?number=xxxxxxx&key=xxxxxx"
        ' Créer un objet XMLHTTP
        Dim xmlHttpRequest As Object
        Set xmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
        ' Ouvrir une connexion à l'URL
        xmlHttpRequest.Open "GET", cheminWeb, False
        xmlHttpRequest.send
        On Error GoTo 0
        If xmlHttpRequest.Status = 200 Then
            ' Charger le contenu HTML de la page dans un objet HTML
                Set htmlDoc = CreateObject("HTMLFile")
                htmlDoc.body.innerHTML = xmlHttpRequest.responseText
                Set elems = htmlDoc.querySelectorAll("div.card-body > p")
                For x = 0 To elems.Length - 1
                    Debug.Print elems.Item(x).innerText
                Next x
                ' Date du relevé
                ws.Range("D2").Value = CDate(Now())
                ' Nom Prénom
                ws.Range("D3").Value = elems.Item(0).innerText
                ' Extraction Nom Prénom
                regex.Pattern = ".+\s(\w+)\s(\w+)"
                Set matches = regex.Execute(elems.Item(0).innerText)
                If Not matches Is Nothing Then
                    ws.Range("D18").Value = Application.WorksheetFunction.Proper(matches(0).Submatches(0)) ' Prénom
                    ws.Range("D17").Value = matches(0).Submatches.Item(1) ' Nom
                Else
                    ws.Range("D18").Value = "??"
                    ws.Range("D17").Value = "??"
                End If
                ' Date de Naissance
                regex.Pattern = "le\s([0-9/]+)"
                Set matches = regex.Execute(elems.Item(1).innerText)
                If Not matches Is Nothing Then
                    ws.Range("D4").Value = CDate(matches(0).Submatches.Item(0))
                Else
                     ws.Range("D4").Value = "??"
                End If
                ' Numéro de Licence
                ws.Range("D6").Value = elems.Item(3).innerText
                ' Date de souscription
                ws.Range("D7").Value = CDate(elems.Item(7).innerText)
                ' Date de validité Licence
                ws.Range("D8").Value = CDate(elems.Item(9).innerText)
                ' Extraction Nom Club + Numéro
                regex.Pattern = "(.+)\(([0-9]+)"
                Set matches = regex.Execute(elems.Item(11).innerText)
                If Not matches Is Nothing Then
                   Debug.Print matches(0).Submatches.Item(0)
                   Debug.Print matches(0).Submatches.Item(1)
                   ws.Range("D10").Value = Trim(matches(0).Submatches.Item(0))
                   ws.Range("D11").NumberFormat = "@"
                   ws.Range("D11").Value = matches(0).Submatches.Item(1)
                Else
                     ws.Range("D10").Value = "??"
                     ws.Range("D11").Value = "??"
                End If
                ' Assurance
                ws.Range("D13").Value = elems.Item(13).innerText
                ' Date Règlement Assurance
                ws.Range("D14").Value = CDate(elems.Item(15).innerText)
                ' Date de validité Assurance
                ws.Range("D15").Value = CDate(elems.Item(17).innerText)
        End If
 Set xmlHttpRequest = Nothing
 Set htmlDoc = Nothing
 Set regex = Nothing
Exit Sub
ErrWeb:
MsgBox "Impossible de lancer la recherche Web "
End Sub

J'obtiens ceci :
Pièce jointe 647759

Attention il y a des risques que cela ne fonctionne pas dans certains cas (infos manquantes, prénoms composés, etc...)

Ami calmant, J.P

14/12/2023, 10h27
Eric_Hockey_Sub

Merci l'Ami Calmant pour la réponse.

Je vais tester cela pour l'adapter à mon projet

Bonne journée
16/12/2023, 03h02
Eric_Hockey_Sub

2 pièce(s) jointe(s)

Bonsoir l'Ami Calmant

Voila ce que j'ai comme erreur qui s'affiche au lancement de la macro

Peut-être ma version 2007 ?

L'appli finale sera utilisée par une centaine d'arbitres, et donc de multiples versions d'Excel possibles .. Pas simple cela

Hello,
c'est louche et cela ne vient pas de la version d'Excel mais plutôt du système d'exploitation et de la version d'internet explorer qui est installée dessus. Quels sont-ils ?
Sinon tu peux essayer ceci pour ne pas utiliser queryselectorAll :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Sub WebsiteInfo2()
Dim cheminWeb As Variant
Dim ws As Worksheet, regex As Object, matches As Object
Dim htmlDoc As Object, elems As Object, elems2 As Object, x As Integer, y As Integer
Dim Infos As New Collection
        With Application
            .ScreenUpdating = False
        End With
        Set ws = Worksheets("Feuil1")
        Set regex = CreateObject("VBScript.RegExp")
        ws.Range("D2:D18") = Empty
        On Error GoTo ErrWeb
        cheminWeb = "https://l.ffessm.fr/Home/InfoLicence?number=039948&key=F263F3"
        ' Créer un objet XMLHTTP
        Dim xmlHttpRequest As Object
        Set xmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
        ' Ouvrir une connexion à l'URL
        xmlHttpRequest.Open "GET", cheminWeb, False
        xmlHttpRequest.send
        On Error GoTo 0
        If xmlHttpRequest.Status = 200 Then
            ' Charger le contenu HTML de la page dans un objet HTML
                Set htmlDoc = CreateObject("HTMLFile")
                htmlDoc.body.innerHTML = xmlHttpRequest.responseText
             '   Set elems = htmlDoc.queryselectorAll("div.card-body > p")
                Set elems = htmlDoc.getElementsByClassName("card-body")
                For x = 0 To elems.Length - 1
                    Set elems2 = elems.Item(x).getElementsByTagName("p")
                    For y = 0 To elems2.Length - 1
                      Debug.Print elems2.Item(y).innerText
                      Infos.Add elems2.Item(y).innerText
                    Next y
                Next x
                ' Date du relevé
                ws.Range("D2").Value = CDate(Now())
                ' Nom Prénom
                ws.Range("D3").Value = Infos(1)
                ' Extraction Nom Prénom
                regex.Pattern = ".+\s(\w+)\s(\w+)"
                Set matches = regex.Execute(Infos(1))
                If Not matches Is Nothing Then
                    ws.Range("D18").Value = Application.WorksheetFunction.Proper(matches(0).Submatches(0)) ' Prénom
                    ws.Range("D17").Value = matches(0).Submatches.Item(1) ' Nom
                Else
                    ws.Range("D18").Value = "??"
                    ws.Range("D17").Value = "??"
                End If
                ' Date de Naissance
                regex.Pattern = "le\s([0-9/]+)"
                Set matches = regex.Execute(Infos(2))
                If Not matches Is Nothing Then
                    ws.Range("D4").Value = CDate(matches(0).Submatches.Item(0))
                Else
                     ws.Range("D4").Value = "??"
                End If
                ' Numéro de Licence
                ws.Range("D6").Value = Infos(4)
                ' Date de souscription
                ws.Range("D7").Value = CDate(Infos(8))
                ' Date de validité Licence
                ws.Range("D8").Value = CDate(Infos(10))
                ' Extraction Nom Club + Numéro
                regex.Pattern = "(.+)\(([0-9]+)"
                Set matches = regex.Execute(Infos(12))
                If Not matches Is Nothing Then
                   Debug.Print matches(0).Submatches.Item(0)
                   Debug.Print matches(0).Submatches.Item(1)
                   ws.Range("D10").Value = Trim(matches(0).Submatches.Item(0))
                   ws.Range("D11").NumberFormat = "@"
                   ws.Range("D11").Value = matches(0).Submatches.Item(1)
                Else
                     ws.Range("D10").Value = "??"
                     ws.Range("D11").Value = "??"
                End If
                ' Assurance
                ws.Range("D13").Value = Infos(14)
                ' Date Règlement Assurance
                ws.Range("D14").Value = CDate(Infos(16))
                ' Date de validité Assurance
                ws.Range("D15").Value = CDate(Infos(18))
        End If
 Set xmlHttpRequest = Nothing
 Set htmlDoc = Nothing
 Set regex = Nothingl'éditeur
Exit Sub
ErrWeb:
MsgBox "Impossible de lancer la recherche Web "
End Sub

Pour tester si le queryselectorall existe.

1 - Aller dans l'éditeur VBA
2 - Dans Outils/Références cocher Microsoft HTML Object Library
3 - Commencer à écrire ce code :

Code:

1
2
3
Sub TestQuerySelectorAll()
Dim HtmlDoc As New MSHTML.HTMLDocument
HtmlDoc.

regarder après le . ce qui est proposé en complétion en particulier voir si il y a querySelectorAll.

Ami calmant, J.P

16/12/2023, 14h55
Eric_Hockey_Sub

2 pièce(s) jointe(s)

alors j'ai bien cocher Microsoft HTML Object Library

J'ai redémarré Excel

J'ai fait ton test et querySelectorAll est bien présent

J'ai testé les 2 macro et pour la 1ere je bloque tjr au même endroit , et la seconde je bloque aussi sur "Set Elems... "

Ce qui est bizarre c'est que le "HtmlDoc.getElementsByClassName("card-body")" fonctionne dans ma macro en dessous ( sub site_fede())
16/12/2023, 15h32
jurassic pork
tu peux essayer alors de remplacer
Code:

1 2 Dim HtmlDoc As Object Set HtmlDoc = CreateObject("HTMLFile")
par

Code:

Dim HtmlDoc As New MSHTML.HTMLDocument

dans les macros
17/12/2023, 00h49
Eric_Hockey_Sub

Merci Jurassic Pork

Cela fonctionne .

J’approfondis mes test et je te confirme tout ça
24/03/2024, 00h18
Eric_Hockey_Sub

Retour d'expérience
Citation:
Envoyé par jurassic pork

tu peux essayer alors de remplacer

Code:

1 2 Dim HtmlDoc As Object Set HtmlDoc = CreateObject("HTMLFile")

par

Code:

Dim HtmlDoc As New MSHTML.HTMLDocument

dans les macros
Bonjour à Tous, Bonjour Jurassic Pork

Voila mon retour d'expérience sur l'utilisation de la macro en générale, mais surtout sur le changement entre

Code:

Dim HtmlDoc As Object

et

Code:

Dim HtmlDoc As New MSHTML.HTMLDocument

Je m'était rendu compte dans un premier temps que sur mon Ordi en Win64 Excel 365 je devais mettre"Object" et avec mon autre poste en Win 32 et Excel 2007 , je devais mettre New MSHTML.HTMLDocument

Je suis parti donc avec un début de macro qui qui choisissait le bon "dim" en fonction de Win64 ou Win32 .

Mon application étant utilisé par de nombreuses personnes, , très vite j'ai pu voir que ce n'était pas la bonne raison, mais uniquement la version d'Excel qui me posait soucis.

LA solution adoptée :

Une petite fonction trouvée ici :

https://excel-malin.com/codes-source...rsion-d-excel/

ma donnée la solution en apportant une petite modif et en utilisant

Code:

VersionExcel = left(Application.Version, 2)

Ensuite je crée 2 macros identiques, ayant comme seule différence le Dim HtmlDoc As .....
1. Object si VersionExcel > 15
2. New MSHTML.HTMLDocument si VersonExcel <= 15
Voila si cela peut aider d'autres personnes

PS : Si une solution plus simple que de faire 2 macros similaires, je suis aussi preneur .
24/03/2024, 00h30
Eric_Hockey_Sub

Citation:

Attention il y a des risques que cela ne fonctionne pas dans certains cas (infos manquantes, prénoms composés, etc...)

Ami calmant, J.P

Bon justement, il y a bien sur des prénoms composés. Ils sont tjr séparé par un trait d'union. (-)

Y a t-il une astuce pour récupérer les prénoms composés depuis ta macro ( qui fonctionne super bien pour tout le reste) .

Merci pour ta macro . Je ne peux pas mettre mon appli ici pour te montrer le fonctionnement dans sa globalité, mais elle va bientot être utilisée par tout les arbitres de Hockey Subaquatiques.
24/03/2024, 01h10
deedolith

Salut,

Une alternative pour piloter les navigateurs web chromium (edge / chrome):
https://github.com/longvh211/Chromiu...th-CDP-for-VBA

Ca supporte XPath, qui est plus précis que QuerySelector.

Hello,

Citation:

Envoyé par Eric_Hockey_Sub

Bon justement, il y a bien sur des prénoms composés. Ils sont tjr séparé par un trait d'union. (-)

Y a t-il une astuce pour récupérer les prénoms composés depuis ta macro ( qui fonctionne super bien pour tout le reste) .

Tu peux essayer ceci comme motif :
Code:

1 2 ' Extraction Nom Prénom regex.Pattern = ".+\s([-\w]+)\s(\w+)"
Pour tester :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub TestPrenomCompose() Dim regex As Object, matches As Object Dim ChaineAtester As String, Nom As String, Prenom As String Set regex = CreateObject("VBScript.RegExp") ChaineAtester = "Mr JEAN-PIERRE FOUCAULT" ' Extraction Nom Prénom regex.Pattern = ".+\s([-\w]+)\s(\w+)" Set matches = regex.Execute(ChaineAtester) If Not matches Is Nothing Then Prenom = Application.WorksheetFunction.Proper(matches(0).Submatches(0)) ' Prénom Nom = matches(0).Submatches.Item(1) ' Nom Else Prenom = "??" Nom = "??" End If Debug.Print Prenom, Nom Set regex = Nothing End Sub
Citation:

Envoyé par deedolith

Une alternative pour piloter les navigateurs web chromium (edge / chrome):
https://github.com/longvh211/Chromiu...th-CDP-for-VBA
Ca supporte XPath, qui est plus précis que QuerySelector.

Il y a un exemple ici avec en plus le moyen de ne pas être "pollué" par les messages de Debug dans la fenêtre d'exécution de VBA.

Ami calmant, J.P

25/03/2024, 19h51
Eric_Hockey_Sub
Citation:

Envoyé par jurassic pork

Hello,

Il y a un exemple ici avec en plus le moyen de ne pas être "pollué" par les messages de Debug dans la fenêtre d'exécution de VBA.

Ami calmant, J.P

Heuu là tu m'a perdu .. désolé :lol:

Par contre pour ça :
Code:

1 2 ' Extraction Nom Prénom regex.Pattern = ".+\s([-\w]+)\s(\w+)"
Ca fonctionne bien . Merciiiiiiii

rela sub info

Bonjour
juste en passant
votre sub info

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub WebsiteInfo()
    Dim xmlHttpRequest As Object, htmlDoc As Object, X&, lesps As Object, I&
 
 
    Sheets("Feuil1").Range("D2:D18") = Empty
 
    cheminWeb = "https://l.ffessm.fr/Home/InfoLicence?number=039948&key=F263F3"
 
    Set xmlHttpRequest = CreateObject("MSXML2.XMLHTTP")
    xmlHttpRequest.Open "GET", cheminWeb, False
    xmlHttpRequest.send
 
    If xmlHttpRequest.Status <> 200 Then
        MsgBox " une erreur est intervenue pendant le telechargement des données"
 
    End If
 
    Set htmlDoc = CreateObject("HTMLFile")
    htmlDoc.body.innerhtml = xmlHttpRequest.responseText
 
    With htmlDoc
        Debug.Print .body.innerhtml
        Set lesps = .getElementsByTagName("P")
        [d3] = lesps(0).innertext
 
        For I = 0 To lesps.Length - 1
            Select Case True
 
            Case InStr(1, lesps(I).innerhtml, "Licence N°") > 0
                [D6] = lesps(I + 1).innertext
 
            Case InStr(1, lesps(I).innerhtml, "Né(e) le") > 0    '
                [d4] = CDate(Split(lesps(I).innertext, "Né(e) le ")(1))
 
            Case InStr(1, lesps(I).innerhtml, "Date de souscription") > 0    '
                [D7] = CDate(lesps(I + 1).innertext)
 
            Case InStr(1, lesps(I).innerhtml, "Date de validité") > 0    '
                If X = 0 Then [D8] = lesps(I + 1).innertext: X = 1
 
                '[10] 'non du club' je sais pas ou il faut chercher
 
                '[d11]'N°club 'je sais pas ou il faut chercher
 
            Case lesps(I).innertext = "Assurance"
                [D13] = lesps(I + 1).innertext
 
            Case InStr(1, lesps(I).innerhtml, "Date de règlement") > 0    '
                [D14] = lesps(I + 1).innertext
 
            Case InStr(1, lesps(I).innerhtml, "Date de validité") > 0    '
                If X = 1 Then [D15] = lesps(I + 1).innertext: X = 2
 
            End Select
        Next
    End With
End Sub