Discussion :

[Eric_Hockey_Sub]

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

[jurassic pork]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :


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

[Eric_Hockey_Sub]

Merci l'Ami Calmant pour la réponse.

Je vais tester cela pour l'adapter à mon projet

Bonne journée

[Eric_Hockey_Sub]

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

[jurassic pork]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Eric_Hockey_Sub]

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())

[Eric_Hockey_Sub]

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.

[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.

[jurassic pork]

Hello,

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Pour tester :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

[Eric_Hockey_Sub]

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é

Par contre pour ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

Ca fonctionne bien . Merciiiiiiii

[patmeziere]

Bonjour
juste en passant
votre sub info

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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