写ASP采集的一些函数

itE-SPACE: normal; LETTER-SPACING: normal; BORDER-COLLAPSE: separate; orphans: 2; widows: 2; webkit-border-horizontal-spacing: 0px; webkit-border-vertical-spacing: 0px; webkit-text-decorations-in-effect: none; webkit-text-size-adjust: auto; webkit-text-stroke-width: 0px"><%



'==================================================

'函数名：GetHttpPage

'作 用：获取网页源码

'参 数：HttpUrl ——网页地址

'==================================================

Function GetHttpPage(HttpUrl)

If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False$" Then

GetHttpPage="$False$"

Exit Function

End If

Dim Http

Set Http=server.createobject("MSXML2.XMLHTTP")

Http.open "GET",HttpUrl,False

Http.Send()

If Http.Readystate<>4 then

Set Http=Nothing 

GetHttpPage="$False$"

Exit function

End if

GetHTTPPage=bytesToBSTR(Http.responseBody,"GB2312")

Set Http=Nothing

If Err.number<>0 then

Err.Clear

End If

End Function



'==================================================

'函数名：BytesToBstr

'作 用：将获取的源码转换为中文

'参 数：Body ——要转换的变量

'参 数：Cset ——要转换的类型

'==================================================

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



'==================================================

'函数名：PostHttpPage

'作 用：登录

'==================================================

Function PostHttpPage(RefererUrl,PostUrl,PostData) 

Dim xmlHttp 

Dim RetStr 

Set xmlHttp = CreateObject("Msxml2.XMLHTTP") 

xmlHttp.Open "POST", PostUrl, False

XmlHTTP.setRequestHeader "Content-Length",Len(PostData) 

xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"

xmlHttp.setRequestHeader "Referer", RefererUrl

xmlHttp.Send PostData 

If Err.Number <> 0 Then 

Set xmlHttp=Nothing

PostHttpPage = "$False$"

Exit Function

End If

PostHttpPage=bytesToBSTR(xmlHttp.responseBody,"GB2312")

Set xmlHttp = nothing

End Function 



'==================================================

'函数名：UrlEncoding

'作 用：转换编码

'==================================================

Function UrlEncoding(DataStr)

Dim StrReturn,Si,ThisChr,InnerCode,Hight8,Low8

StrReturn = ""

For Si = 1 To Len(DataStr)

ThisChr = Mid(DataStr,Si,1)

If Abs(Asc(ThisChr)) < &HFF Then

StrReturn = StrReturn & ThisChr

Else

InnerCode = Asc(ThisChr)

If InnerCode < 0 Then

InnerCode = InnerCode &H10000

End If

Hight8 = (InnerCode And &HFF00) &HFF

Low8 = InnerCode And &HFF

StrReturn = StrReturn & "%" & Hex(Hight8) & "%" & Hex(Low8)

End If

Next

UrlEncoding = StrReturn

End Function



'==================================================

'函数名：GetBody

'作 用：截取字符串

'参 数：ConStr ——将要截取的字符串

'参 数：StartStr ——开始字符串

'参 数：OverStr ——结束字符串

'参 数：IncluL ——是否包含StartStr

'参 数：IncluR ——是否包含OverStr

'==================================================

Function GetBody(ConStr,StartStr,OverStr,IncluL,IncluR)

If ConStr="$False$" or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then

GetBody="$False$"

Exit Function

End If

Dim ConStrTemp

Dim Start,Over

ConStrTemp=Lcase(ConStr)

StartStr=Lcase(StartStr)

OverStr=Lcase(OverStr)

Start = InStrB(1, ConStrTemp, StartStr, vbBinaryCompare)

If Start<=0 then

GetBody="$False$"

Exit Function

Else

If IncluL=False Then

Start=Start LenB(StartStr)

End If

End If

Over=InStrB(Start,ConStrTemp,OverStr,vbBinaryCompare)

If Over<=0 Or Over<=Start then

GetBody="$False$"

Exit Function

Else

If IncluR=True Then

Over=Over LenB(OverStr)

End If

End If

GetBody=MidB(ConStr,Start,Over-Start)

End Function



%>



天气小偷范本



<%

On Error Resume Next

Server.ScriptTimeOut=9999999

Function getHTTPPage(Path)

t = GetBody(Path)

getHTTPPage=BytesToBstr(t,"GB2312")

End function



Function GetBody(url) 

on error resume next

Set Retrieval = CreateObject("Microsoft.XMLHTTP") 

With Retrieval 

.Open "Get", url, False, "", "" 

.Send 

GetBody = .ResponseBody

End With 

Set Retrieval = Nothing 

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 Newstring(wstr,strng)

Newstring=Instr(lcase(wstr),lcase(strng))

if Newstring<=0 then Newstring=Len(wstr)

End Function

%>



<%

Dim wstr,str,url,start,over,city

city = Request.QueryString("id")

url="http://appnews.qq.com/cgi-bin/news_qq_search?city="&city&""

wstr=getHTTPPage(url)

start=Newstring(wstr,"<html>")

over=Newstring(wstr,"</HTML>")

body=mid(wstr,start,over-start)



body = replace(body,"skin1","天气预报 – 斯克网络")

body = replace(body,"http://appnews.qq.com/cgi-bin/news_qq_search?city","tianqi.asp?id")





response.write body

%>