Titre du sujet : Re: Recupération d'infos sur ParisTurf
par myDearFriend! le 06/02/2011 22:18:35
Bonsoir chpaca, jc24, le Forum,
Oui, effectivement, je confirme ce que dis notre ami jc24 : pour comprendre ton classeur, il faut certainement être un fondu de Turf... Ce qui n'est pas vraiment mon cas, à vrai dire.
Cela dit, et pour répondre aux explications de ton premier post, tu trouveras ci-joint une interprétation de ce que j'ai compris.
J'ai utilisé le code suivant :
DANS LE MODULE DE CODE DE LA FEUILLE 1
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Application.Intersect(Target, Columns(2)) Is Nothing Then
If Target.Value <> "" Then
Cancel = True
RecupListeChevaux Target.Offset(0, 1)
End If
End If
End Sub
DANS UN MODULE DE CODE STANDARD
Option Explicit
'--------------------------------------------------------------------
' Auteur : Didier FOURGEOT (myDearFriend!) - www.mdf-xlpages.com
' Date : 06/02/2011
' Sujet : Récup données Web Paris-Turf.com
'--------------------------------------------------------------------
Sub MAJlisteCourses()
Dim IE As InternetExplorer
Dim IEDoc As HTMLDocument
Dim IElien As HTMLLinkElement
Dim Col As New Collection
Dim T As String
Dim L As Long, VerifL As Long, Lign As Long
Const vURL As String = "http://www.paris-turf.com/"
'TRAITEMENT
Sheets(1).Range("B:C").ClearContents
Application.ScreenUpdating = False
'Crée une instance d'IE invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'Ouvre la page Web
IE.Navigate vURL
Do Until IE.readyState = READYSTATE_COMPLETE
DoEvents
Loop
'Récupère la liste de tous les ID intéressants (ID Courses sans doublon)
Set IEDoc = IE.Document
On Error Resume Next
With Sheets(1)
Lign = 5
For L = 0 To IEDoc.Links.Length - 1
Set IElien = IEDoc.Links(L)
T = IElien
If T Like "*course.html?idcourse=*" Then
If Val(IElien.innerText) < 1 Then
VerifL = Col.Count
Col.Add IElien.innerText, IElien.innerText 'Sans doublon
If VerifL <> Col.Count Then
Lign = Lign + 1
.Cells(Lign, 2).Value = IElien.innerText 'Nom de la course
.Cells(Lign, 3).Value = CStr(Right(T, 6)) 'ID de la course
End If
End If
End If
Next L
End With
On Error GoTo 0
IE.Quit
Application.ScreenUpdating = True
Beep
MsgBox "Actualisation terminée !"
End Sub
Sub RecupListeChevaux(IDcourse As String)
Dim IE As InternetExplorer
Dim WbkCible As Workbook
Dim IEDoc As HTMLDocument
Dim IElien As HTMLLinkElement
Dim Col As New Collection
Dim vURL As String, T As String
Dim NbC As Long
vURL = "http://www.paris-turf.com/reunion/pid ... ltats&idcourse=" & IDcourse
'Crée le classeur de stats chevaux
Workbooks.Add
'TRAITEMENT
'Crée une instance d'IE invisible
Set IE = CreateObject("internetExplorer.Application")
IE.Visible = False
'Ouvre la page Web
IE.Navigate vURL
Do Until IE.readyState = READYSTATE_COMPLETE
DoEvents
Loop
'Récupère la liste de tous les ID intéressants(ID Chevaux sans doublon)
Set IEDoc = IE.Document
T = IEDoc.DocumentElement.innerHTML
IE.Quit
On Error Resume Next
NbC = InStr(1, T, "appelAjaxResume(this.id, 'CH',")
Do While NbC > 0
NbC = InStr(1, T, "appelAjaxResume(this.id, 'CH',")
T = Mid(T, NbC + 30)
If Val(T) > 0 Then Col.Add CStr(Val(T)), CStr(Val(T))
Loop
'Crée un onglet par cheval
For NbC = 0 To Col.Count - 1
RecupCheval IDcourse, Col(NbC), NbC
DoEvents
Application.StatusBar = "Traitement en cours > " & CStr(CInt(NbC * 100 / Col.Count)) & " %"
Next NbC
On Error GoTo 0
Application.ScreenUpdating = True
Application.StatusBar = False
Beep
MsgBox "Récupération terminée !"
End Sub
Sub RecupCheval(IDcourse As String, IDcheval As String, N As Long)
Dim R As Range
Dim vURL As String
vURL = "http://www.paris-turf.com/dossier-lay ... torique_des_courses" _
& "&idcheval=" & IDcheval & "&idcourse=" & IDcourse
Worksheets.Add(After:=Sheets(Sheets.Count)).Name = "Ch " & CStr(N)
With ActiveSheet.QueryTables.Add(Connection:="URL;" & vURL, Destination:=Range("A1"))
.Name = "LaRequete"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With
End Sub
Le principe de fonctionnement est le suivant :
- Clic sur le bouton pour actualiser la liste des courses du jour (et récupération des ID correspondants)
- Double-clic sur un élément de la liste (course) pour obtenir les stats des chevaux dans un nouveau classeur.
En espérant que ça puisse te dépanner...
Cordialement,
|
Didier FOURGEOT