C'est un petit bout de code pour récupérer des infos sur une page web. Il est possible de parser (décomposer élément par élément) correctement une page HTML (ou mieux : XML) à condition quelle soit bien structurée. En l'occurrence, je ne fais que rechercher bêtement du texte dans la page, avec pour exemple, la récupération de la note d'un film sur imdb (HTML sans structure affirmée). C'est simple, mais cela permet de faire des récupérateurs automatiques plus puissants pour alimenter des bases de données (recommandation : pillez le web avec modération quand même :-)
Source / Exemple :
Nouveau (en plus du projet VB dans le fichier zip) : une mise en oeuvre sur plusieurs pages HTMl successives dans DVDClass :
DVDCLASS : UN COMPILATEUR DE CRITIQUES DE DVD
www.vbfrance.com/article.asp?Val=2313
modification du code VB en Access VBA dans un Formulaire WebScraper :
Option Compare Database
' Variables globales
Dim bFinNavigation As Boolean, bMajEnCours As Boolean
Dim bEchec As Boolean
Dim rNote!, sInfos$
Private Sub CmdWebScraper_Click()
' Si bMajEnCours on interromp la mise à jour
If bMajEnCours Then bMajEnCours = False: Exit Sub
'WebBrowser1.Offline = True
CmdWebScraper.Caption = "Stop"
bMajEnCours = True
Dim sSQL$, Rq As Recordset, sWeb$
Dim iNbEchecs%, sListeEchecs$
Dim i%, iNbFilmsImdb%
sSQL = "SELECT Oeuvre.Oeuvre, Oeuvre.Web, Vote.Vote" & _
" FROM Votant INNER JOIN (Oeuvre INNER JOIN Vote ON Oeuvre.IdOeuvre = Vote.IdOeuvre) ON Votant.IdVotant = Vote.IdVotant" & _
" WHERE Oeuvre.Web Like 'www.imdb.com/*' AND Votant.Surnom='IMDB';"
'Oeuvre.Web<>'nul'
'Oeuvre.Oeuvre Like 's*' AND
Set Rq = CurrentDb.OpenRecordset(sSQL)
If Not (Rq.BOF And Rq.EOF) Then
Rq.MoveLast
iNbFilmsImdb = Rq.RecordCount
Rq.MoveFirst
End If
LblInfos.Caption = "..."
While Not Rq.EOF
i = i + 1
'LblInfos.Caption = i & " / " & iNbFilmsImdb
bEchec = False
bFinNavigation = False
rNote = -1
sInfos = ""
sWeb = sLireLienIMDB(Nz(Rq!Web), , bFranciserIMDB:=True)
'MsgBox sWeb
WebBrowser1.Navigate sWeb
While Not bFinNavigation
If Not bMajEnCours Then GoTo Fin
DoEvents
Wend
If bEchec Then
'Stop
iNbEchecs = iNbEchecs + 1
sListeEchecs = sListeEchecs & sWeb & " "
End If
LblInfos.Caption = i & " / " & iNbFilmsImdb & " : " & sInfos
If rNote > -1 And rNote <> Nz(Rq!Vote, -1) Then
Rq.Edit
Rq!Vote = rNote
Rq.Update
End If
Rq.MoveNext
Wend
Fin:
Rq.Close
If i = iNbFilmsImdb Then
MsgBox "Mise à jour terminée !"
Else
MsgBox "Mise à jour interrompue !"
End If
If iNbEchecs > 0 Then MsgBox "Nombre d'échecs : " & iNbEchecs & vbLf & sListeEchecs
CmdWebScraper.Caption = "Go !"
End Sub
Private Sub Form_Load()
LblInfos.Caption = ""
End Sub
Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim doc As IHTMLDocument2
On Error Resume Next
Set doc = WebBrowser1.Document
If Err Then Exit Sub
' Un appel est généré lors du chargement du formulaire
If doc.Title = "Impossible de trouver le serveur" Then GoTo Echec
' La pub génère un appel parasite
If Left$(URL, 20) <> "http://www.imdb.com/" Then Exit Sub
Dim sTxt$, iPosG%, iPosD%, iNbCar%, sAutresTitres$
Dim Quote As IHTMLElement
sAutresTitres = "Pas d'autres titres"
Set Quote = doc.body
sTxt = Quote.innerText
Const sTxtNote$ = "User Rating:"
iNbCar = Len(sTxtNote)
iPosG = InStr(sTxt, sTxtNote)
If iPosG = 0 Then GoTo Echec
iPosD = InStr(iPosG, sTxt, "/10")
If iPosD = 0 Then GoTo Echec
sNote = Trim$(Mid$(sTxt, iPosG + iNbCar, iPosD - iPosG - iNbCar))
Const sTxtAKA$ = "Also Known As:"
Const sTxtRuntime$ = "Runtime:"
iNbCar = Len(sTxtAKA)
iPosG = InStr(sTxt, sTxtAKA)
If iPosG = 0 Then GoTo Fin
iPosD = InStr(iPosG, sTxt, sTxtRuntime)
If iPosD = 0 Then GoTo Fin
sAutresTitres = Trim$(Mid$(sTxt, iPosG + iNbCar, iPosD - iPosG - iNbCar))
Fin:
sInfos = "URL : " & URL & " :" & vbCrLf & _
"Titre : " & doc.Title & vbCrLf & _
"Note : " & sNote & "/10"
'"Autres titres : " & sAutresTitres
'MsgBox sInfo
bFinNavigation = True
rNote = Val(sNote)
Exit Sub
Echec:
bEchec = True
Exit Sub
End Sub
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.