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
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
| Dim tablo_lien1(15, 15, 1) '13 lig sur 15 col 'Aujourd'hui
'Dim tablo_lien2(10, 15) 'Demain
'Dim tablo_lien3(10, 15) 'après-demain
Dim tablo
Dim Ok As Boolean
Public madate
Public thecell As Range
Sub reunion1() '(madate)
DLig = ThisWorkbook.Worksheets("Réunion1").Range("B" & Rows.Count).End(xlUp).Row + 1
madate = Date 'ThisWorkbook.Worksheets("Accueil").Range("B2")
Set thecell = ThisWorkbook.Worksheets("Réunion1").Range("A" & DLig)
starts 'madate
'recup_donnéees 0
End Sub
Sub starts() '(madate)
'supprime tableau
Sheets("Temp").Range("A1:N20").Clear
url = "http://www.zeturf.fr/fr/programmes-et-pronostics"
'appel sub pour récup lien réunions
recupe_lien_Reunions url
Do: DoEvents: Loop Until Ok = True
Ok = False: recupe_lien_Courses
'Sheets("Temp").Cells(1, 1).Resize(13, 15) = tablo_lien1
'Transfère les éléments du tableau dans la feuille de calcul
Sheets("Temp").Cells(1, 1).Resize(UBound(tablo_lien1, 1), UBound(tablo_lien1, 2)) = tablo_lien1
End Sub
Public Function recupe_html(url)
Dim REQ
Set REQ = CreateObject("microsoft.xmlhttp")
REQ.Open "POST", url, False
REQ.send
recupe_html = REQ.responseText
End Function
Sub recupe_lien_Reunions(url)
Dim matable, mestables
With CreateObject("htmlfile")
.write recupe_html(url)
'pour aujourd'hui, demain et après-demain
Set mesjours = .getelementsbytagname("div")
For j = 0 To mesjours.Length - 1
i = 0
If mesjours(j).ID = "box_day" Then
If mesjours(j).innertext <> "" Then
jour = Split(Trim(mesjours(j).innertext), " - ")(0)
If jour = "Aujourd'hui" Then
tablo_lien1(0, 0, 0) = jour
Set Table = mesjours(j).Children(1).getelementsbytagname("a")
For T = 0 To Table.Length - 1
Set matab = Table(T)
If matab.className = "halfpill" Then
tablo_lien1(i, 1, 0) = matab.Title 'hippo
tablo_lien1(i, 2, 0) = matab.innertext 'R1
tablo_lien1(i, 3, 0) = matab.href 'lien
i = i + 1
End If
If i = 4 Then Exit For
Next
ElseIf jour = "Demain" Then
Set Table = mesjours(j).Children(1).getelementsbytagname("a")
tablo_lien1(4, 0, 0) = jour
For T = 0 To Table.Length - 1
Set matab = Table(T)
If matab.className = "halfpill" Then
tablo_lien1(4 + i, 1, 0) = matab.Title 'hippo
tablo_lien1(4 + i, 2, 0) = matab.innertext 'R1
tablo_lien1(4 + i, 3, 0) = matab.href 'lien
i = i + 1
End If
If i = 4 Then Exit For
Next
ElseIf jour = "Après-demain" Then
Set Table = mesjours(j).Children(1).getelementsbytagname("a")
tablo_lien1(8, 0, 0) = jour
For T = 0 To Table.Length - 1
Set matab = Table(T)
If matab.className = "halfpill" Then
tablo_lien1(8 + i, 1, 0) = matab.Title 'hippo
tablo_lien1(8 + i, 2, 0) = matab.innertext 'R1
tablo_lien1(8 + i, 3, 0) = matab.href 'lien
i = i + 1
End If
If i = 4 Then Exit For
Next
End If
End If
End If
Next
End With
Ok = True
End Sub
Sub recupe_lien_Courses()
Dim matable, mestables
'pour les 4 réunions sur 4 lignes
For a = 0 To 7
url = tablo_lien1(a, 3, 0)
With CreateObject("htmlfile")
.write recupe_html(url)
Set mestables = .getelementsbytagname("TABLE") 'tableau courses recup lien RC
col = 4
For i = 0 To mestables.Length - 1
If mestables(i).className = "double" Then
Set matable = mestables(i)
Set cours = matable.Children(0).getelementsbytagname("a") '(0)
For c = 0 To cours.Length - 1
If cours(c).className = "pill" Then
tablo_lien1(a, col, 0) = cours(c).href 'recup lien course
Debug.Print cours(c).href
tablo_lien1(a, col, 1) = matable.Rows(col - 3).Children(6).innertext
Debug.Print matable.Rows(col - 3).Children(6).innertext 'heure 1ère courses
col = col + 1
End If 'course
Next
End If 'mestables
Next i
End With
Next a
End Sub |
re
: ça peut servir aux autres 
Répondre avec citation
j'apprendrai encore
, comme çà je pourrais étudier ton code?
Partager