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

mathieurac 4 Messages postés vendredi 2 septembre 2011Date d'inscription 8 septembre 2011 Dernière intervention - 2 sept. 2011 à 17:19 - Dernière réponse : bigfish_le vrai 1839 Messages postés vendredi 13 mai 2005Date d'inscription 20 novembre 2013 Dernière intervention
- 8 sept. 2011 à 17:41
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\test\temp.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.
Afficher la suite 

Votre réponse

7 réponses

Meilleure réponse
bigfish_le vrai 1839 Messages postés vendredi 13 mai 2005Date d'inscription 20 novembre 2013 Dernière intervention - 8 sept. 2011 à 17:41
3
Merci
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’é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+

Merci bigfish_le vrai 3

Avec quelques mots c'est encore mieux Ajouter un commentaire

Codes Sources a aidé 96 internautes ce mois-ci

Commenter la réponse de bigfish_le vrai
cs_MPi 3877 Messages postés mardi 19 mars 2002Date d'inscription 23 août 2018 Dernière intervention - 5 sept. 2011 à 15:30
0
Merci
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
Commenter la réponse de cs_MPi
mathieurac 4 Messages postés vendredi 2 septembre 2011Date d'inscription 8 septembre 2011 Dernière intervention - 5 sept. 2011 à 15:47
0
Merci
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.
Commenter la réponse de mathieurac
cs_MPi 3877 Messages postés mardi 19 mars 2002Date d'inscription 23 août 2018 Dernière intervention - 5 sept. 2011 à 18:01
0
Merci
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
Commenter la réponse de cs_MPi
cs_MPi 3877 Messages postés mardi 19 mars 2002Date d'inscription 23 août 2018 Dernière intervention - 5 sept. 2011 à 18:02
0
Merci
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
Commenter la réponse de cs_MPi
mathieurac 4 Messages postés vendredi 2 septembre 2011Date d'inscription 8 septembre 2011 Dernière intervention - 7 sept. 2011 à 10:22
0
Merci
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.
Commenter la réponse de mathieurac
mathieurac 4 Messages postés vendredi 2 septembre 2011Date d'inscription 8 septembre 2011 Dernière intervention - 8 sept. 2011 à 15:59
0
Merci
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 & "\temp.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
Commenter la réponse de mathieurac

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.