[VBA] Faire une recherche dans le code source d'une page webRésolu

Question

Bonjour,

J'aurais besoin de vos lumières car je sèche sur quelques lignes de code :
- J'ai un fichier excel dans lequel je colle des liens d'autres fichiers excel issus de l'intranet afin de pouvoir les télécharger dans un fichier local.
- Ce que je souhaiterai faire, c'est automatiser la collecte de ces liens.
- Pour ce faire j'ai commencé un code qui cherche le code source d'un site pour en extraire tous les liens avec "xslm" par exemple.
Le problème c'est que j'obtiens ce code source via objDoc.body.innerHTML, je ne sais pas si je peux directement faire une recherche à partir de ceci. J'ai essayé de coller le contenu dans excel, mais c'est trop grand pour une cellule, idem pour un fichier texte temporaire.
Je joins un bout de code :


Public Sub Gethtml()

dim txt
Dim dest, sourcecode As String
Dim IE As Object, objDoc As Object
Dim myURL As String

'l'url du site intranet, mais peu importe le site
myURL = Range("B1").Value


Set IE = CreateObject("internetexplorer.application")
IE.navigate myURL

'Wait for page to load!
Do
If IE.readyState = 4 Then
IE.Visible = False
Exit Do
Else
DoEvents
End If
Loop

Set objDoc = IE.document

'destination du fichier txt temporaire
dest = "D:\Shared	est	emp.txt"

'Html
Set fsys = CreateObject("Scripting.FileSystemObject")
Set txt = fsys.CreateTextFile(dest)
filecode = FreeFile

sourcecode=objDoc.body.innerHTML

'Ouverture fichier txt temporaire pour copie donnees
Open dest For Output As filecode
Print #filecode, sourcecode
Close #filecode

'reste a faire l'argument de recherche mais avant ça, je dois pouvoir exploiter le code source..

'copie du code source vers une cellule (juste pour test)
'Sheets("Source").Range("A1").Value = objDoc.body.innerHTML


Set objDoc = Nothing
Set IE = Nothing

End Sub


Mon code est loin d'etre optimisé parce que j'ai pas mal bidouillé en cherchant des solutions alternatives comme avec sendkeys par exemple, que j'ai enlevés par la suite.

Quelqu'un a-t-il une idée?
Merci.

bigfish_le vrai · Accepted Answer

Salut,

voici la démo d'une méthode un peu moins lourde:

Sub RecherecheLien()
    ' déclaration des variables
    Dim ObjectIE As Object, MonUrl As String
    Dim MesElements As Object, i As Long, j As Long
    
    MonUrl = "http://www.vbfrance.com"
    Set ObjectIE = CreateObject("InternetExplorer.Application")
    'ObjectIE.Visible = True
    
    ObjectIE.navigate (MonUrl)
    Do Until ObjectIE.READYSTATE = 4: DoEvents: Loop
    Do While ObjectIE.Busy: DoEvents: Loop
    
    DoEvents
    Set MesElements = ObjectIE.Document.getElementsByTagName("a") ' "a" represente une collection d'objets "Element"
    j = 1
    For i = 0 To MesElements.Length - 1
        'si l'innertext de l&#8217;élément contient le mot "codes"
        If LCase$(MesElements(i).getAttribute("innertext")) Like "*codes*" Then
            'on récupère le lien
            Range("A" & j).Value = (MesElements(i).getAttribute("href")) 'ici "href" renvoi l'url recherchée. "href" est une propriété de "a"
            j = j + 1
        End If
    Next
    ObjectIE.Quit
    Set ObjectIE = Nothing
End Sub

la démo fonctionne avec la première page de Vbfrance et renvois tous les liens qui contiennent le mot "codes"

A+

cs_MPi · Answer

Salut,

Je ne comprends pas exactement ce que tu cherches à faire, mais as-tu pensé à utiliser les "données externes" ?

Tu pourrais importer les données directement dans une ou plusieurs feuilles et les travailler par la suite...


MPi²
Pour ceux qui programment sous Office, n'oubliez pas qu'il existe un forum dédié à ces applications VBA....... ICI

mathieurac · Answer

Bonjour,

En fait je veux que mon programme aille exporter le code source d'une page html, peut importe ou, pour y rechercher tous les liens pointant vers des fichiers xlsm, puis coller ces liens dans des cellules d'un fichier Excel.

Avec la technique que j'ai employée, à savoir le body.innerHTML, j'obtiens le code source voulu, mais étant donné qu'il est "d'un bloc" et volumineux (environ 6000 lignes) je n'arrive pas à le coller ou tout du moins pas en entier dans une cellule.

Que veux-tu dire par "donnees externes"?

Merci.

cs_MPi · Answer

J'utilise Excel 2007, alors pour les données externes, tu vas dans l'onglet Données et tu sélectionnes le bouton "Données externes" puis le bouton "À partir du site web". Pour les versions précédentes, je ne me rappelle plus, mais ça devrait exister.

Tu inscris l'adresse web recherchée et tu vas voir des petites flèches pointant sur des "tables" de la page. Tu prends alors celle(s) qui t'intéressent.

Je me suis servi de ces 2 codes pour aller chercher les pointages de joueurs sur un site web...

Un code équivalent à ceci (Données externes):
    Dim I As Long, nbLignes As Long, Adresse As String
    
    For I = 1 To 29     'Liste de 29 adresses URL
        Adresse = Sheets("Data").Range("V" & I)
        nbLignes = Cells(Rows.Count, "A").End(xlUp).Row + 2
        With ActiveSheet.QueryTables.Add(Connection:="URL;" & Adresse, Destination:=Range("A" & nbLignes))
            .Name = Right(Adresse, Len(Adresse) - 1) & "_1"
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = True
            .RefreshStyle = xlInsertDeleteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "4"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
    Next

-------------------------------------------------------------------------
Ou encore tu peux utiliser ce genre de code, avec un contrôle WebBrowser, si tu veux le faire "manuellement". 

Sub Whatever

    strURL = ListBox1.List(ListBox1.ListIndex, 1)
    WebBrowser1.Navigate strURL
end sub

Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    Dim I As Integer, nbLignes As Long
    Dim tabloNom() As String, tabloPoints() As String, tabloRang(), tabloEquipe() As String
    Dim Existe As Boolean, strURL As String
    Dim tablo(256), arrTables, LaTable
    
    On Error GoTo Erreur
    
    Existe = False
    
    Set Doc = WebBrowser1.Document
    Set arrTables = Doc.getElementsByTagName("TABLE")
    For Each LaTable In arrTables
        If LaTable.Rows.Length > 15 Then
            Set MonElement = LaTable
            Exit For
        End If
    Next
    
    If MonElement Is Nothing Then
        MsgBox "Le programme a eu un problème à se connecter", , ThisWorkbook.Name
        Exit Sub
    End If
    
    ReDim tabloRang(0)
    ReDim tabloEquipe(0)
    ReDim tabloNom(0)
    ReDim tabloPoints(0)
    
    For I = 0 To MonElement.Rows.Length - 1
        ReDim Preserve tabloRang(I)
        ReDim Preserve tabloNom(I)
        ReDim Preserve tabloEquipe(I)
        ReDim Preserve tabloPoints(I)
        tabloRang(I) = Val(MonElement.Rows(I).Cells(0).innerText)
        tabloNom(I) = Trim(MonElement.Rows(I).Cells(1).innerText)
        tabloEquipe(I) = Trim(MonElement.Rows(I).Cells(2).innerText)
        tabloPoints(I) = Trim(MonElement.Rows(I).Cells(7).innerText)
    Next I
    
    If UBound(tabloNom) > 0 Then
        For I = 0 To UBound(tabloNom)
            If tabloRang(I) > 0 Then
                Cells(tabloRang(I), 3) = tabloEquipe(I)
                Cells(tabloRang(I), 2) = tabloNom(I)
                Cells(tabloRang(I), 8) = tabloPoints(I)
                Existe = True
            End If
        Next
        
        If Existe Then
            ListBox1.List(ListBox1.ListIndex, 2) = "OK"
            Cells(tabloRang(I - 1), 1).Select
            If ListBox1.ListIndex + 1 < ListBox1.ListCount Then
               'changement d'adresse ce qui rappelle la présente procédure
                ListBox1.ListIndex = ListBox1.ListIndex + 1
                strURL = ListBox1.List(ListBox1.ListIndex, 1)
                WebBrowser1.Navigate strURL
            End If
        End If
    Else
    'changement d'adresse ce qui rappelle la présente procédure
        strURL = ListBox1.List(ListBox1.ListIndex, 1) 
        WebBrowser1.Navigate strURL
    End If
    
    Exit Sub

Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
'    Stop
'    Resume
    
End Sub


Mais je trouve la première option beaucoup plus facile à gérer et ça ne cause pas ou peu d'erreurs.

MPi²
Pour ceux qui programment sous Office, n'oubliez pas qu'il existe un forum dédié à ces applications VBA....... ICI

cs_MPi · Answer

Désolé pour la mise en forme du code.
Je pensais que ça réagirait aussi bien qu'avant, même sans les couleurs.
Ça fait un bout de temps que je n'ai rien inscrit sur le forum...


MPi²
Pour ceux qui programment sous Office, n'oubliez pas qu'il existe un forum dédié à ces applications VBA....... ICI

mathieurac · Answer

Bonjour,

Merci pour ta réponse.
J'ai testé les différentes solutions que tu as proposé, malheureusement c'est un peu plus compliqué, car le site source en question etant du sharepoint, les données voulues se trouvent sous des "+" et Excel ne les voit pas via cette technique de données externes, il ne prend que les noms des sous-menus.

mathieurac · Answer

Bonjour,

Je suis finalement arrivé à mes fins avec un code sensiblement identique à celui de départ, je le partage au cas uo il pourrait servir à quelqu'un d'autre :

Public Sub Gethtml()

Dim dest, xlsfile, myURL, Period As String
Dim IE As Object, objDoc As Object
Dim filecode, LastRowA, i, n, j As Integer
Dim txt
Dim tabtemp(1000)


'Clean the sheet
Range("A5:B300").ClearContents

  Application.DisplayAlerts = False
  xlsfile = ActiveWorkbook.Name
  myURL = Range("B1").Value
  Period = Range("B3").Value
  i = 1
  
Sheets("Macro").Select
Application.DisplayAlerts = True

Set IE = CreateObject("internetexplorer.application")

IE.navigate myURL

'Waiting IE is ready
 Do
  If IE.readyState = 4 Then
   IE.Visible = False
   Exit Do
  Else
   DoEvents
  End If
 Loop

  Set objDoc = IE.document

  'Path of temporary file
  dest = Range("B2").Value
  dest = dest & "	emp.txt"

  Set fsys = CreateObject("Scripting.FileSystemObject")

  ' Check if the file already exists
  If fsys.FileExists(dest) = False Then
   Set txt = fsys.CreateTextFile(dest)
   Set txt = Nothing
  End If

   nFile = FreeFile
   nFile2 = FreeFile

   ' Write the source code of the URL in the temporary file
   Open dest For Output Shared As #nFile
   Print #nFile, objDoc.DocumentElement.innerHTML
   Close #nFile

   ' Check every line and copy the path to the next line
   Open dest For Input As #nFile2
   While Not EOF(nFile2)
    Line Input #nFile2, txtline
    If txtline Like "*xls*" And txtline Like ("*" & Period & "*") And txtline Like "*href*" Then
     tabtemp(i) = InStr(txtline, "href")
     tabtemp(i) = Mid(txtline, tabtemp(i) + 6)
     txtline = tabtemp(i)
      If txtline Like "*xlsm*" Then
       tabtemp(i) = InStr(txtline, "xlsm")
       tabtemp(i) = Left(txtline, tabtemp(i) + 3)
      ElseIf txtline Like "*xlsx*" Then
       tabtemp(i) = InStr(txtline, "xlsx")
       tabtemp(i) = Left(txtline, tabtemp(i) + 3)
      ElseIf txtline Like "*xls*" Then
       tabtemp(i) = InStr(txtline, "xls")
       tabtemp(i) = Left(txtline, tabtemp(i) + 2)
      End If
       i = i + 1
       n = i
    End If
   Wend
   Close #nFile2

j = 5

'Check for double lines
For i = 1 To n
 If tabtemp(i) <> tabtemp(i - 1) Then
  Sheets("Macro").Range("A" & j).Value = tabtemp(i)
  j = j + 1
 End If
Next

     Kill dest
     Windows(xlsfile).Activate
    
     IE.Application.Quit
     Set objDoc = Nothing
     Set IE = Nothing

End Sub

[VBA] Faire une recherche dans le code source d'une page web

7 réponses

Votre réponse

Discussions similaires