写ASP采集的一些函数
2013-08-13 09:55
183 查看
写ASP采集的一些函数
'================================================== '函数名: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 C or C 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 %>
相关文章推荐
- 写ASP采集的一些函数
- 面向对象的asp编程之四--一些常用的函数
- asp 小偷采集程序原理与常用函数方法
- asp 采集程序常用函数分析
- ASP采集入库生成本地文件的几个函数
- 平时在做ASP.NET项目里经常使用的一些函数和方法
- asp.net 一些常用的处理函数代码
- asp+XMLHTTP组件做采集常用函数
- Asp中一些FSO方面的函数
- ASP.NET 程序设计中常用到的一些通用函数 自己的封装 可以做成dll来使用。
- 在采集程序中,定时器函数和WindowProc函数存在的一些问题
- Asp防止采集的函数
- Asp中一些FSO方面的函数
- GetPaing 函数之asp采集函数中用到的获取分页的代码
- asp 小偷采集程序原理与常用函数方法
- 我写ASP时常用到的一些函数
- asp+XMLHTTP组件做采集常用函数收集
- 平时在做ASP.NET项目里经常使用的一些函数和方法〔zz〕
- asp的一些函数收集
- Asp中一些FSO方面的函数