asp資料采集

asp資料采集

資料采集程式

'On Error Resume Next

Server.Scripttimeout=300

'---------------------------------------------------------------------

'采集資料

Function getHTTPData(url) 

    dim http 

    set http=Server.createobject("Msxml2.XMLHTTP")

    if instr(url,"http://")=0 then url="http://"&url

    Http.open "GET",url,false 

    Http.send() 

    if Http.Status<>200  then exit function 

    getHTTPData=bytesToBSTR(Http.responseBody,"UTF-8")

    set http=nothing

    if err.number<>0 then err.Clear

    sCharset="" 

End function

'---------------------------------------------------------------------        

Function BytesToBstr(body,Cset)

    dim objstream

    set objstream = Server.CreateObject("adodb.stream")

    objstream.Type = 1

    objstream.Mode =3

    objstream.Open

    objstream.Write body

    objstream.Position = 0

    objstream.Type = 2

    objstream.Charset = Cset

    BytesToBstr = objstream.ReadText 

    objstream.Close

    set objstream = nothing

End Function

'---------------------------------------------------------------------    

'伺服器登入

Function login(url) 

    if Http.Status<>200 then exit function 

'正則替換

Function ReplaceText(fString,patrn, replStr)

    Set regEx = New RegExp

    regEx.Pattern = patrn

    regEx.IgnoreCase = True

    regEx.Global = True

    ReplaceText = regEx.Replace(fString, replStr)

'去标簽 包括内容

Function ReplaceTag(str, tag)

    regEx.Pattern = "<"&tag&"[^>]*?>.*?<\/"&tag&">"

    ReplaceTag=regEx.Replace(str, "")

'去标簽 不包括内容

Function ReplaceTab(str, tag)

    regEx.Pattern = "<\/?"&tag&"[^>]*>"

    ReplaceTab=regEx.Replace(str, "")

'去标簽屬性 保留标簽

Function ReplaceinnerTag(str, tag)

    regEx.Pattern = "(<\/?"&tag&")[^>]*>"

    ReplaceinnerTag=regEx.Replace(str, "$1>")

'按正則取資料

Function getText(fString, patrn,n) 

    dim Matches, tStr

    tStr = fString

    Set re = New Regexp

    re.IgnoreCase = True

    re.Global = True

    re.Pattern =  patrn

    set Matches = re.Execute(tStr)

    set re = nothing 

    rStr = ""

    For Each Match in Matches

        rStr = Match.SubMatches(n)

        exit for

    Next

    getText = rStr

'資料過濾

Function Encode_text(str)

    If Isnull(str) Then

        Encode_text = ""

        Exit Function 

    End If

    str = ReplaceText(str, "<\/?br[^>]*>" , vbCrlf )

    str = ReplaceText(str, "<\/?p[^>]*>" , vbCrlf )

    str = ReplaceTab(str, "[a-zA-Z]")

    str = ReplaceText(str, "\n\s*\r" ,Chr(10)&Chr(13))

    str = Replace(str, "&" , "&" )

    str = Replace(str, ";" , ";" )

    str = Replace(str, "&" , "&" )

    str = Replace(str,Chr(34), """ )

    str = Replace(str, "'" , "'" )

    str = Replace(str, "<" , "<" )

    str = Replace(str, ">" , ">" )

    str = Replace(str, "(" , "(" )

    str = Replace(str, ")" , ")" )

    str = Replace(str, "*" , "*" )

    str = Replace(str, "%" , "%" )

    str = Replace(str,vbCrlf, "<br/>" )

    Encode_text = str

'通過Matches取資料

dim Matches

sub setMatches(str,sRe)

    re.Pattern =  sRe

    set Matches = re.Execute(str)

    set re=nothing 

end sub

例子

'例子

call setMatches(textcontent, re)

For Each Match in Matches

    response.write Match.value

Next