写ASP采集的一些函数
2008-05-28 23:49
323 查看
<% /'================================================== /'函数名:GetHttpPage /'作 用:获取网页源码 /'参 数:HttpUrl ------网页地址 /'================================================== Function GetHttpPage(HttpUrl) If IsNull(HttpUrl)=True Or Len(HttpUrl)<18 Or HttpUrl="$False___FCKpd___0quot; Then GetHttpPage="$False___FCKpd___0quot; 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___FCKpd___0quot; 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___FCKpd___0quot; 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___FCKpd___0quot; or ConStr="" or IsNull(ConStr)=True Or StartStr="" or IsNull(StartStr)=True Or OverStr="" or IsNull(OverStr)=True Then GetBody="$False___FCKpd___0quot; 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___FCKpd___0quot; 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___FCKpd___0quot; 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 %>
相关文章推荐
- 写ASP采集的一些函数
- ASP的一些自定义函数整理第1/2页
- 平时在做ASP.NET项目里经常使用的一些函数和方法
- 我常用的一些ASP自定义函数
- Asp编程中的一些重要函数(1)
- Asp中一些FSO方面的函数
- GetPaing 函数之asp采集函数中用到的获取分页的代码
- 我写ASP时常用到的一些函数
- asp.net 一些常用的处理函数代码
- asp.net一些全局常用函数
- asp+XMLHTTP组件做采集常用函数收集
- 我常用的一些ASP自定义函数
- asp代理采集的核心函数代码
- asp代理采集的核心函数代码
- ASP采集程序常用功能函数
- Asp中一些FSO方面的函数
- ASP.NET中处理datetime的一些通用函数
- ASP的一些自定义函数整理第1/2页
- 写ASP时常用到的一些函数
- Asp防止采集的函数