Webscraper : pillez le web avec modération !

Télécharger le projet
Commenter

Description

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
Télécharger le projet

Codes Sources

S'inscrire maintenant

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.

Du même auteur (cs_Patrice99)