![]() |
#2
ysf01812012-07-23 11:47
dim myHttp
set myHttp=new xhttp myHttp.URL=http://www. Response.Write(myHttp.html) '保存远程图片到本地 myHttp.URL="http://www.baidu.com/page/asp.gif" myHttp.saveimage="myfile.gif" '为防止xhttp卡死的情况,使用超时,错误处理 dim sHtmlcode,iStep myHttp.URL="http://www. " sHtmlcode=myHttp.html do while myHttp.xhttpError="" Response.Error("ERROR: AGAIN!<br />") sHtmlcode=myHttp.html iStep=iStep+1 if iStep>100 then Response.Write("ERROR:OVER!<hr />") exit do end if loop Response.Write(sHtmlcode) set myHttp=nothing '-------------------------------------------------------------------- Class xhttp private cset,sUrl,sError Private Sub Class_Initialize() 'cset="UTF-8" cset="GB2312" sError="" end sub Private Sub Class_Terminate() End Sub Public Property LET URL(theurl) sUrl=theurl end property public property GET BasePath() BasePath=mid(sUrl,1,InStrRev(sUrl,"/")-1) end property public property GET FileName() FileName=mid(sUrl,InStrRev(sUrl,"/")+1) end property public property GET Html() Html=BytesToBstr(getBody(sUrl)) end property public property GET xhttpError() xhttpError=sError end property private Function BytesToBstr(body) on error resume next 'Cset:GB2312 UTF-8 dim objstream set objstream = Server.CreateObject("adodb.stream") with objstream .Type = 1 ' .Mode = 3 ' .Open .Write body ' .Position = 0 ' .Type = 2 ' .Charset = Cset ' BytesToBstr = .ReadText ' .Close end with set objstream = nothing End Function private function getBody(surl) on error resume next dim xmlHttp 'Set xmlHttp=server.createobject("Msxml2.XMLHTTP.4.0") 'set xmlHttp=server.createobject("Microsoft.XMLHTTP") set xmlHttp=server.createobject("MSXML2.ServerXMLHTTP") xmlHttp.setTimeouts 10000,10000,10000,30000 xmlHttp.open "GET",surl,false xmlHttp.send if xmlHttp.readystate=4 then 'if xmlHttp.status=200 then getBody=xmlhttp.responsebody 'end if else getBody="" end if if Err.Number<>0 then sError=Err.Number Err.clear else sError="" end if set xmlHttp=nothing end function Public function saveimage(tofile) on error resume next dim objStream,imgs imgs=getBody(sUrl) Set objStream = Server.CreateObject("ADODB.Stream") with objStream .Type =1 .Open .write imgs .SaveToFile server.mappath(tofile),2 .Close() end with set objstream=nothing end function end class 提示:Server.UrlEncode 在这里起到很关键作用,没这个系统可能一下可以一下不行。原因就是Server.UrlEncode的功能,接受处理页面获取得到值是乱码,程序给你不执行的。所有传递汉字参数的都要加这个 Server.UrlEndcode 错误写法:myHttp.URL=“http://www.汉字&id=11&rnum="&now() 正确写法:myHttp.URL=“http://www.("汉字")&"&id=11&rnum="&now() 更正确的写法:myHttp.URL=“http://220.110.777.99/test.asp?test_hanzi="&Server.UrlEncode("汉字")&"&id=11&rnum="&now() '这个可以在对方不能上网的服务器(dns)也能连。 这个代码加上我的提示,你写的接口连接一般会很稳定。 [ 本帖最后由 ysf0181 于 2012-7-23 13:42 编辑 ] |
<%
'以下是接口的例子及函数
Response.Clear
On Error Resume Next
response.Buffer=false
err.clear
server.ScriptTimeout=9999999
'执行模块,整个程序的流程。由上至下的走..先看GetResStr(URL) 他首先打开网页.然后将网站的html下载回来后.
'然后再用正则表达来处理你需要的值。而这里演示的是直接取得他的标题..
'最后将值转换一下。然后输出到浏览器。。整个流程就如此了
dim reg,vUrl,pUrl,VBody,title
vUrl="http://www.baidu.com" '更换网站地址
reg="\<meta.+ charset= {0,}([^\"" \>\/]*).+\/{0,1}\>"
if vUrl<>"" then '取得网站标题
VBody=GetResStr(vUrl)
title=GetCode(VBody,"\<title\>(.*)\<\/title\>")
else
vUrl="地址取不到"
end if
if err.number<>0 then
response.write "标题出错"
else
if title<>"" then
response.write title
else
response.write "标题为空"
end if
end if
response.End()
'函数名:GetResStr
'作用:获取指定URL的HTML代码
'参数:URL-要获取的URL
function GetResStr(URL)
err.clear
dim ResBody,ResStr,PageCode,ReturnStr
Set Http=server.createobject("msxml2.serverxmlhttp.3.0") '先创建一个serverxmlhttp对像.并指明他是3.0版本的..可以省去
Http.setTimeouts 10000, 10000, 10000, 10000 '设置超时时间
Http.open "GET",URL,False '以上已设置后。就打开网址。参数1:提交方式,url地址,异步执行 一般选择异步执行
Http.Send() '调用Send方法发送XML数据
If Http.Readystate =4 Then '文档已经解析完毕,客户端可以接受返回消息
If Http.status=200 Then '接收返回的错误
ResStr=http.responseText '接收返回的信息..(源代码一般)
ResBody=http.responseBody '以html方式返回消息
PageCode=GetCode(ResStr,reg) '用正则表达式。将网站返回的title值进行匹配。如果有就返回。。否则返回gbk2312
ReturnStr=BytesToBstr(http.responseBody,PageCode) '需要将其转换一下..
GetResStr=ReturnStr '返回值
End If
End If
End Function
'函数名:BytesToBstr
'作用:转换二进制数据为字符
'参数:Body-二进制数据,Cset-文本编码方式
Function BytesToBstr(Body,Cset)
Dim Objstream
Set Objstream = Server.CreateObject("adodb.stream") '创建一个字符流....
objstream.Type = 1 '返回的数据类型 adTypeBinary =1 adTypeText =2
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
'函数名:GetCode
'作用:转换二进制为字符
'参数:str-待查询字符串,regstr-正则表达式
Function GetCode(str,regstr)
Dim Reg,serStr
set Reg= new RegExp '先创建一个正则表达式..
Reg.IgnoreCase = True '设置是否区分字符大小写
Reg.MultiLine = True '多行方式保存
Reg.Pattern =regstr '查找html中有没有 \<meta.+ charset= {0,}([^\"" \>\/]*).+\/{0,1}\> 匹配
if Reg.test(str) then '若查询到匹配项
Set Cols = Reg.Execute(str)
serStr=Cols(0).SubMatches(0) '使用匹配到的第一个匹配项
else '否则给个默认值gb2312,有点省懒法,如果页面没给出编码格式,想知道确实有点麻烦
serStr="gb2312"
end if
GetCode=serStr
end function
%>
[ 本帖最后由 ysf0181 于 2012-7-23 11:27 编辑 ]