右上角文字广告 | 加入收藏 | 繁體中文 | 网站地图
热门搜索:网页游戏 火箭球赛 热门音乐 2011世界杯 亚运会 黄海军演
您现在的位置:首页 >> 房产家居 >> 内容

写ASP采集的一些函数

时间:2010-11-10 9:40:40 点击:

PSE: 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
%>

作者:不详 来源:网络
相关评论
发表我的评论
  • 大名:
  • 内容:
本类推荐
  • 没有
本类固顶
  • 没有
  • 关于我们 | 系统介绍 | 使用说明 | 联系我们 | 网站商城
  • 新世纪门户网站,新世纪建站,免费建站,自助建站,建站教程,建站源码(menhu.6000y.com) © 2018 All Rights Reserved.
  • 站长QQ:249181841 晋ICP备05000479号
  • Powered by 我要学建站建站