Extraire toutes les url d'une page web (hyperlien ou non)

[vergez]

Bonsoir tout le monde et bienvenue sur ce forum (ça c’est pour moi ;-))

Je viens de passer 2 jours de mes courtes vacances à essayer de trouver une solution mais rien n’y fait … je jette l’éponge et viens m’enquérir de votre aide …

Mon but serait d’extraire toutes les url’s trouvées dans une série de pages web. Mais pas seulement les url’s déclarées comme hyperliens mais aussi toute « suite de caractères » commençant par http://*

Le problème étant alors de ne pas toujours avoir une belle séparation de fin de lien puisque cela peut être une guillemet, un crochet de balise html, etc.

Je ne cherche pas à avoir un code 100% parfait mais du moins, un code qui laisserait échapper le moins de liens possible.

Le point de départ qui me semble le plus adéquat : mes pages internet sont sauvegardées en csv dans un répertoir spéial (je suis déjà arrivé à automatiser cela).

Un tout grand merci d’avance.

 

[PMO2]

Re : Extraire toutes les url d'une page web (hyperlien ou non)

Bonjour,

Une piste avec le code suivant à copier dans un module standard. Adaptez, à votre usage, la constante MY_URL cernée par des ###.

'### Constante à adapter ###
Const MY_URL = "http://www.excel-downloads.com/forum/133466-extraire-toutes-les-url-dune-page-web-hyperlien-ou-non.html"
'###########################

Declare Function InternetOpen& Lib "wininet" Alias "InternetOpenA" ( _
  ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
    ByVal sProxyBypass As String, ByVal lFlags As Long)
Declare Function InternetCloseHandle& Lib "wininet" (ByVal hInet As Long) 'As Integer
Declare Function URLDownloadToFile& Lib "urlmon" Alias "URLDownloadToFileA" ( _
  ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long)

Const INTERNET_OPEN_TYPE_DIRECT = 1
Const FICHIER_TEMPO As String = "C:\___tempo_pmo.txt"

Sub ExtraireUrls()
Dim Inet&
Dim canal&
Dim A$
Dim T()
Dim T2()
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim S As Worksheet
Dim R As Range
Inet& = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
Inet& = URLDownloadToFile(0, MY_URL, FICHIER_TEMPO, 0, 0)
Call InternetCloseHandle(Inet&)
canal& = FreeFile
Open FICHIER_TEMPO For Input As #canal&
While Not EOF(canal&)
  i& = i& + 1
  ReDim Preserve T(1 To i&)
  Line Input #canal&, T(i&)
Wend
Close #canal&
For i& = 1 To UBound(T)
  A$ = T(i&)
  j& = InStr(1, A$, Chr(34) & "http://")
  If j& > 0 Then
    k& = InStr(1, Mid(A$, j& + 1), Chr(34))
    If k& > 0 Then
      cpt& = cpt& + 1
      ReDim Preserve T2(1 To cpt&)
      T2(cpt&) = Mid(A$, j& + 1, k& - 1)
    End If
  End If
Next i&
If cpt& > 0 Then
  Erase T
  ReDim T(1 To UBound(T2), 1 To 1)
  For i& = 1 To UBound(T2)
    T(i&, 1) = T2(i&)
  Next i&
  Set S = Sheets.Add(after:=Sheets(Sheets.Count))
  Set R = S.Range("a1:a" & UBound(T) & "")
  R = T
End If
If Dir(FICHIER_TEMPO) <> "" Then Kill FICHIER_TEMPO
End Sub

Si des résultats sont trouvés ils iront s'inscrire dans une nouvelle feuille.

Cordialement.

PMO
Patrick Morange

 

[vergez]

Re : Extraire toutes les url d'une page web (hyperlien ou non)

Bonjour pmo et bonnes fêtes en avance pour ce soir.

J'ai essayé le code mais malheureusement, il ne prend apparement que les hyperliens. Dans une page, par exemple, il a omis toutes les urls comprises dans ce genre de tag :

[pre]
http://...
http://...
http://...
[/pre]

PS : désolé mais les réponses à cette question commencent à ressembler à une autre question que j'ai posé dans une discussion vis à is d'une demande différente. Je ne crois pas que cela soit un mal ... mais je voulais juste prévenir pour éviter toute remarque à ce sujet

 

[PMO2]

Re : Extraire toutes les url d'une page web (hyperlien ou non)

Bonjour,

A tout hasard, essayez de changer la ligne de code

j& = InStr(1, A$, Chr(34) & "http://")

par

j& = InStr(1, A$,  "http://")

Le programme cherchera à partir de http:// et non pas à partir de "http://

Le problème est que je ne sais pas sur quel caractère me caler pour déterminer la fin de la URL.

Pouvez-vous indiquer l'URL de la page web que vous explorez ?

Cordialement.

PMO
Patrick Morange

 

[vergez]

Re : Extraire toutes les url d'une page web (hyperlien ou non)

Tout content, un premier test a fonctionné ... mais pas un deuxième site et pourtant, les liens se retrouvaient exactement dans la même balise :

[pre class="alt2" dir="ltr" style="border: 1px inset ; margin: 0px; padding: 6px; overflow: auto; width: 640px; height: 162px; text-align: left;"]

Le problème, c'est que la fin de l'url diffère à chaque fois ... cela peut-être du ".html", du ".zip", un chiffre, une balise, etc.

Je pense que l'idée de départ est la bonne, extraire toutes les url des hyperliens de la page ... et dans un 2ème temps, il faudrait apparement extraire tout le texte brut qui apparait sur le browser.
Nous aurions donc au final une liste d'url suivies d'une liste de "textes" avec la présentation d'une url par cellule.

Je n'aurais plus ensuite qu'à faire un tri alpha et de filtrer les urls dont j'ai besoin et le tour est joué. Plus besoin de prévoir une fin d'url changeante ....

Bref, éventuellement deux sub différents mais intégrés vers une même destination ...

 

[PMO2]

Re : Extraire toutes les url d'une page web (hyperlien ou non)

Bonjour,

Voici une nouvelle version qui peut mieux répondre à votre problème :

'### Constante à adapter ###
Const MY_URL = "http://www.excel-downloads.com/forum/133466-extraire-toutes-les-url-dune-page-web-hyperlien-ou-non.html"
'###########################

Declare Function InternetOpen& Lib "wininet" Alias "InternetOpenA" ( _
  ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, _
    ByVal sProxyBypass As String, ByVal lFlags As Long)
Declare Function InternetCloseHandle& Lib "wininet" (ByVal hInet As Long) 'As Integer
Declare Function URLDownloadToFile& Lib "urlmon" Alias "URLDownloadToFileA" ( _
  ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, _
  ByVal dwReserved As Long, ByVal lpfnCB As Long)

Const INTERNET_OPEN_TYPE_DIRECT = 1
Const FICHIER_TEMPO As String = "C:\___tempo_pmo.txt"

Sub ExtraireUrls()
Dim Inet&
Dim canal&
Dim A$
Dim T()
Dim T2()
Dim COLOR()
Dim h&
Dim i&
Dim j&
Dim k&
Dim cpt&
Dim S As Worksheet
Dim R As Range
Dim CALAGE_CHAR_FIN As Variant

  '--- Spécifie les différents caractères de fin
  '--- Adaptez l'instruction ci-dessous pour ajouter
  '--- d'éventuels autres caractères de fin
  '--- Ex : CALAGE_CHAR_FIN = Array(Chr(34), " ", ".", "]",".zip")
CALAGE_CHAR_FIN = Array(Chr(34), " ")
  '---------------------------

Inet& = InternetOpen(vbNullString, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
Inet& = URLDownloadToFile(0, MY_URL, FICHIER_TEMPO, 0, 0)
Call InternetCloseHandle(Inet&)
canal& = FreeFile
Open FICHIER_TEMPO For Input As #canal&
While Not EOF(canal&)
  i& = i& + 1
  ReDim Preserve T(1 To i&)
  Line Input #canal&, T(i&)
Wend
Close #canal&
For i& = 1 To UBound(T)
  A$ = T(i&)
  j& = InStr(1, A$, "http://")
  If j& > 0 Then
    For h& = LBound(CALAGE_CHAR_FIN) To UBound(CALAGE_CHAR_FIN)
      k& = InStr(1, Mid(A$, j& + 1), CALAGE_CHAR_FIN(h&))
      If k& > 0 Then Exit For
    Next h&
    cpt& = cpt& + 1
    ReDim Preserve T2(1 To cpt&)
    ReDim Preserve COLOR(1 To cpt&)
    If h& > UBound(CALAGE_CHAR_FIN) Then h& = 29
    COLOR(cpt&) = h& + 1
    If k& > 0 Then
      T2(cpt&) = Mid(A$, j&, k& + Len(CALAGE_CHAR_FIN(h&)))
      If Mid(A$, j& - 1, 1) = Chr(34) Then T2(cpt&) = Chr(34) & T2(cpt&)
    Else
      T2(cpt&) = Mid(A$, j&)
    End If
  End If
Next i&
If cpt& > 0 Then
  Erase T
  ReDim T(1 To UBound(T2), 1 To 1)
  For i& = 1 To UBound(T2)
    T(i&, 1) = T2(i&)
  Next i&
  Set S = Sheets.Add(after:=Sheets(Sheets.Count))
  Set R = S.Range("a1:a" & UBound(T) & "")
  R = T
End If
S.Columns(1).Insert
For i& = 1 To R.Rows.Count
  Range("a" & i& & "") = COLOR(i&)
  Range("b" & i& & "").Font.ColorIndex = COLOR(i&)
Next i&
S.Cells.Columns.AutoFit
If Dir(FICHIER_TEMPO) <> "" Then Kill FICHIER_TEMPO
End Sub

Il vous faut adapter le Array du variant CALAGE_CHAR_FIN pour indiquer les divers caractères de fin.

Si on trouve la chaîne http:// on balaie le tableau CALAGE_CHAR_FIN à la recherche d'un possible caractère de fin.
Si un caractère de fin est trouvé, on sort de la boucle sur le tableau CALAGE_CHAR_FIN et on obtient un résultat avec ce caractère de fin.
Sinon le résultat sera tout le reste de la chaîne.

Les résultats s'affiche en colonne B d'une nouvelle feuille et la police est colorée en fonction du caractère de fin.
En colonne A est indiqué le rang du caractère de fin trouvé ce qui permettra de trier les résultats à partir du rang.

Cordialement.

PMO
Patrick Morange