Requète XMLHttp et IE

**jbonneval** · 24/03/2017, 12h25

Bonjour,

J’essaye 2 méthodes différentes pour le chargement de data web via excel :
La première fonctionne en pas à pas correctement

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
 
Sub LFWHOSC()
'Permet de cahrger les matchs sur internet et le numero d'identifiant du match "1080####" (col A)
'La procédure fonctionne en pas à pas mais pas en Run(F5) car il doit manqué une temporisation avant le Set IEDoc
'L'inconvénient de se chargement: Je ne peux pas toucher au PC, le timer plante 1 fois sur 4
'Application.ScreenUpdating = False
'Application.Visible = False
Dim IE As New InternetExplorer
Dim IEDoc As HTMLDocument
 
Dim wsWSC As Worksheet
Set wsWSC = ThisWorkbook.Worksheets("WSC")
 
IE.navigate "https://www.whoscored.com/Regions/252/Tournaments/2/England-Premier-League"
IE.Visible = False
Set IEDoc = IE.document
Dim htmlTabResultat As HTMLGenericElement
Dim htmlLigneResultat As HTMLGenericElement
Dim NumLigne As Byte
Dim NumImg As Byte
Set htmlTabResultat = IEDoc.body.all("tournament-fixture").Children(0) '
wsWSC.Range("A2") = "n° Match"
wsWSC.Range("B2") = "Equipe n°1"
wsWSC.Range("C2") = "Equipe n°2"
wsWSC.Range("D2") = "Résultat"
NumLigne = 3
For Each htmlLigneResultat In htmlTabResultat.Children
 
    If htmlLigneResultat.Children(0).innerText Like "*, * * ####" Then
        wsWSC.Cells(NumLigne, "A") = htmlLigneResultat.Children(0).innerText
    Else
        wsWSC.Cells(NumLigne, "A") = Mid(Left(htmlLigneResultat.outerhtml, InStr(htmlLigneResultat.outerhtml, "><") - 2), InStr(htmlLigneResultat.outerhtml, "data-id=") + 9)
        wsWSC.Cells(NumLigne, "B") = htmlLigneResultat.Children(1).innerText
        wsWSC.Cells(NumLigne, "C") = htmlLigneResultat.Children(2).innerText
        wsWSC.Cells(NumLigne, "D") = htmlLigneResultat.Children(3).innerText
        wsWSC.Cells(NumLigne, "E") = htmlLigneResultat.Children(4).innerText
        wsWSC.Cells(NumLigne, "F") = htmlLigneResultat.Children(5).innerText
    End If
    NumLigne = NumLigne + 1
Next
 
'Application.ScreenUpdating = True
'Application.Visible = True
End Sub

Nom : IE.png
Affichages : 512
Taille : 204,3 Ko

La seconde méthode XMLHttp, je n’arrive pas à l’adapter en ayant un bout de code qui fonctionne.
Le bout de code qui fonctionne correctement :

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
Public Sub parsehtml()
Dim http As Object, html As New HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://news.ycombinator.com/", False
http.send
html.body.innerHTML = http.responseText
 
Set topics = html.getElementsByClassName("athing")
i = 2
 
For Each topic In topics
    Set titleElem = topic.getElementsByTagName("td")(2)
    Sheets(2).Cells(i, 1).Value = titleElem.getElementsByTagName("a")(0).innerText 'thevet
    Sheets(2).Cells(i, 2).Value = titleElem.getElementsByTagName("a")(0).href '"https://..wiki
    Set detailsElem = topic.NextSibling.getElementsByTagName("td")(1)
    Sheets(2).Cells(i, 3).Value = detailsElem.getElementsByTagName("span")(0).innerText
    Sheets(2).Cells(i, 4).Value = detailsElem.getElementsByTagName("a")(0).innerText
    i = i + 1
Next
End Sub

Le code que j’essaye d’adapter sans succès:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Public Sub parsehtml()
Dim http As Object, html As New HTMLDocument, topics As Object, titleElem As Object, detailsElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://www.whoscored.com/Regions/252/Tournaments/2/England-Premier-League", False
http.send
html.body.innerHTML = http.responseText
'Debug.Print http.responseText
Set topics = html.getElementsByClassName("item alt")
i = 2
For Each topic In topics
    i = i + 1
Next
End Sub

En mettant un espion sur topics, on s’apercoit qu’il n’y a pas d’items contrairement au bout de code fonctionnement.
Nom : XML_Item_missing.png
Affichages : 516
Taille : 142,1 Ko

Nom : XML_Item_missing.png
Affichages : 516
Taille : 142,1 Ko

avec l'espion identifiant les items
Nom : XML_Item_ok.png
Affichages : 528
Taille : 134,5 Ko

Sauriez-vous pourquoi ?
Mon but est d’obtenir la même chose qu’avec la première procédure utilisant IE.

Merci d’avance
Jérôme

**Marc-L** · 24/03/2017, 16h46

Bonjour,

cela semble normal à cause de la recherche sur la classe souvent erratique comme expliqué dans les tutoriels !
Vaut mieux rechercher sur un autre type d'élément comme par exemple un ID (ou name) ou encore un tag name …

Voir déjà les nombreux exemples dans ce forum.

___________________________________________________________________________________________________________

Je suis Paris, London, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

**jbonneval** · 27/03/2017, 13h01

Merci Marc-L pour ton retour,

Ci dessous le code qui m'a permis d'arriver à mes fins (cad. faire le chargement d'une table HTML en mode invisible)

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
89
90
91
92
93
94
Option Explicit
Sub IE_Autiomation3_Calendrier()
 
    On Error GoTo Error_on_IE_Auto
    Call ini_sub
    Dim i As Long
    Dim IE As Object
    Dim IEDoc As Object
    Dim objElement As Object
    Dim objCollection As Object
 
 
    ' Create InternetExplorer Object
    Set IE = CreateObject("InternetExplorer.Application")
 
    ' You can uncoment Next line To see form results
    IE.Visible = False
 
    IE.navigate "https://www.whoscored.com/Regions/108/Tournaments/5/Italy-Serie-A"
 
    ' Wait while IE loading...
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop
 
Set IEDoc = IE.document
 
Dim htmlTabResultat As HTMLGenericElement
Dim htmlLigneResultat As HTMLGenericElement
Dim NumLigne As Byte
Dim NumImg As Byte
 
Set htmlTabResultat = IEDoc.body.all("tournament-fixture").Children(0) '
 
'AppActivate "Microsoft Excel"
 Dim wsWSC As Worksheet
 Set wsWSC = ThisWorkbook.Worksheets("WSC")
NumLigne = 2
For Each htmlLigneResultat In htmlTabResultat.Children
 
    If htmlLigneResultat.Children(0).innerText Like "*, * * ####" Then
        wsWSC.Cells(NumLigne, "A") = htmlLigneResultat.Children(0).innerText
    Else
        wsWSC.Cells(NumLigne, "A") = Mid(Left(htmlLigneResultat.outerHTML, InStr(htmlLigneResultat.outerHTML, "><") - 2), InStr(htmlLigneResultat.outerHTML, "data-id=") + 9)
        wsWSC.Cells(NumLigne, "B") = htmlLigneResultat.Children(1).innerText
        wsWSC.Cells(NumLigne, "C") = htmlLigneResultat.Children(2).innerText
        wsWSC.Cells(NumLigne, "D") = htmlLigneResultat.Children(3).innerText
        wsWSC.Cells(NumLigne, "E") = htmlLigneResultat.Children(4).innerText
        wsWSC.Cells(NumLigne, "F") = htmlLigneResultat.Children(5).innerText
    End If
    NumLigne = NumLigne + 1
Next
    ' Clean up
    Set IE = Nothing
    Set objElement = Nothing
    Set objCollection = Nothing
 
    Application.StatusBar = ""
    'IE.Quit
    'MsgBox "ok"
        Call fin_sub
    Exit Sub
 
Error_on_IE_Auto:
    MsgBox "Erreur on IE_Atomation3 lors du chargement de la team : " '& Worksheets("ToDoDSClas").Range("A" & o + 1)
    Set IE = Nothing
    Set objElement = Nothing
    Set objCollection = Nothing
    Call fin_sub
 
End Sub
 
 
Public Sub ini_sub()
    Application.Visible = False
    Application.DisplayAlerts = False 'messages excel
    Application.DisplayStatusBar = True ' info avancement macro dans barre d'infos en bas écran
    Application.StatusBar = "Synthèse PEPS en cours"
    Application.ScreenUpdating = False 'rafraichissement ecran (pour ne pas voir défiler les macros)
    Application.Cursor = xlWait 'sablier
    Application.Calculation = xlCalculationManual ' supprime calcul auto EXCEL pour gagner du temps.  A remettre dans fin_sub
 
End Sub
 
 
Public Sub fin_sub()
    Application.DisplayAlerts = True
    Application.StatusBar = "Synthèse OK"
    Application.ScreenUpdating = True 'rafrfraichissement ecran
    Application.Cursor = xlDefault 'sablier
    Application.Calculation = xlCalculationAutomatic
    Application.Visible = True
 
End Sub

**Marc-L** · 27/03/2017, 13h12

De mon côté ce code déclenche le message « Erreur lors du chargement de la Team » …

S'il s'agit juste de charger une table de la page d'accueil c'est directement réalisable sans piloter IE via une requête
pour peu que les données se trouvent dans le code HTML initial de cette page (via responseText)
comme dans le lien de la présentation initiale (et ce en 20 lignes de code car il s'agit juste d'extraire du texte du code HTML) :

Requète XMLHttp et IE [XL-2010]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager