retorna todos os links encontrado no html

[xanburzum 169]

Essa função busca uma seqüência que representa uma página html para tags html

e retorna todos os links encontrado no html. ela retorna um Scripting.Dictionary contendo 0 ou mais pares ou

chave combinações de valor.A chave é o URL como está escrito no HREF="" parte de uma

tag âncora e o valor é o que está entre as tags <A> </ A>

 

 

Private Function PegarHref(byval html)
    	dim re, matches, match, d, uri, name

    	Set d = server.createobject("scripting.dictionary")
    	Set re = new regexp
    	re.pattern = "<A(.+?)HREF=""(.+?)""(.+?)>(.+?)</A>"
    	re.ignorecase = true
    	re.multiline = true
    	re.global = true
    	Set matches = re.execute(html)
    	For Each match in matches
    		uri = match.submatches(1)
    		name = match.submatches(3)

    		if not d.exists(uri) then d.add uri, name
    	Next
    	Set matches = Nothing
    	Set re = Nothing

    	Set PegarHref= d
    End Function

exemplo:

 

dim href, d, htmltxt

    htmltxt = WebPage("http://www.sua_pagina.com.br/teste/index.asp")

     ' chamada de função para analisar o texto HTML
    Set d = PegarHref(htmltxt)

     'loop para retornar dicionário de URLs e nomes de âncora
    For Each href in d.keys
    	Response.Write(href & "<BR>")
    	Response.Write(Server.HtmlEncode(d(href)) & "<BR><BR>")
    Next

    Set d = Nothing

[Patrique 0]

Ta faltando a function WebPage, ela é utilizada aqui

 

htmltxt = WebPage("http://www.sua_pagina.com.br/teste/index.asp")

[]'s

[Patrique 0]

Fui a luta e busqueiiiiiii

 

ta ae pra quem quiser...

 

<%
Private Function GetWebPage(ByVal HTTPAddress, ByVal CharSet)
    Dim strContent, xml_http, strBody, strText, max
    '--- Fetch the web page
    On error resume next
    Set xml_http = Server.CreateObject("Microsoft.XMLHTTP")
        xml_http.Open "GET", HTTPAddress, False
        xml_http.Send
        If Err Then
            GetWebPage = ""
            Exit Function
        End If
        strContent = xml_http.responseBody
    Set xml_http = Nothing
    On Error GoTo 0
    '--- Converts the binary content to text
      '--- Create Stream object
      Dim BinaryStream
      Set BinaryStream = CreateObject("ADODB.Stream")
      '--- Specify stream type - we want To save text/string data.
      BinaryStream.Type = 1
      '--- Open the stream And write text/string data To the object
      BinaryStream.Open
      BinaryStream.Write strContent
      '--- Change stream type To binary
      BinaryStream.Position = 0
      BinaryStream.Type = 2
      '--- Specify charset For the source text (unicode) data.
      If Len(CharSet) > 0 Then
        BinaryStream.CharSet = CharSet
      Else
        BinaryStream.CharSet = "UTF-8"
      End If
      '--- Open the stream And get binary data from the object
      strText = BinaryStream.ReadText
        '--- remove headers
        max = InStr(1, strText, Chr(10) & Chr(10), 1)
        GetWebPage = Mid(strText, max + 1)
End Function

dim href, d, htmltxt

 '--- Use the <a href="../main/asp_functions.asp?id=GetWebPage Function">GetWebPage function</a>
 htmltxt = GetWebPage("http://www.livio.net/main/default.asp", "")

 '--- call GetHrefs function to parse html text
Set d = GetHrefs(htmltxt)

 '--- loop through returned dictionary of urls and anchor names
For Each href in d.keys
    Response.Write("key = " & href & "<BR>")
    Response.Write("value = " & Server.HtmlEncode(d(href)) & "<BR>")
Next

Set d = Nothing

Private Function GetHrefs(ByVal html)
    dim re, matches, match, d, uri, name

    Set d = createobject("scripting.dictionary")
    Set re = new regexp
    re.pattern = "<A(.+?)HREF=""(.+?)""(.+?)>(.+?)</A>"
    re.ignorecase = true
    re.multiline = true
    re.global = true
    Set matches = re.execute(html)
    For Each match in matches
        uri = match.submatches(1)
        name = match.submatches(3)

        if not d.exists(uri) then d.add uri, name
    Next
    Set matches = Nothing
    Set re = Nothing

    Set gethrefs = d
End Function
%>

Retirado de: http://www.livio.net/main/asp_functions.asp?id=GetHrefs%20Function