注册 登录
编程论坛 ASP技术论坛

Asp利用XmlHttp采集网页数据

VB爱上我 发布于 2011-10-29 22:04, 468 次点击
<%
On Error Resume Next
Server.ScriptTimeOut=300
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

'------------------------------------------------------------
'获取源字符串中以某字符串开始并且以某字符串结束,中间的那段字符串
'SourceStr : 源字符串
'BeginStr : 开始字符串
'EndStr : 结束字符串
'WithB : 是否包含开始字符串(1代表包含0代表不包含)
'WithE : 是否包含结束字符串(1代表包含0代表不包含)
'说明:开始字符串一定要保证是唯一字符串,否则会是在源字符串中第一次出现的那个位置
'-----------------------------------------------------------------------------
function GetMidWith(byval SourceStr,BeginStr,EndStr,WithB,WithE)
 dim bIndex
 bIndex = instr(SourceStr,BeginStr)
 if bIndex <= 0 then GetMidWith = "":exit function
 
 SourceStr = mid(SourceStr,bIndex + len(BeginStr))'不包含开始字符串
 
 bIndex = instr(SourceStr,EndStr)
 if bIndex <= 0 then GetMidWith = SourceStr:exit function

 if WithE = 1 then
  GetMidWith = mid(SourceStr,1,bIndex + len(EndStr) - 1)'包含结束字符串
 else
  GetMidWith = mid(SourceStr,1,bIndex-1)'不包含结束字符串
 end if
 
 
 if WithB = 1 then GetMidWith = BeginStr & GetMidWith'包含开始字符串
end function

'------------------------------------------------------------
'获取源字符串中以某字符串开始并且以某字符串结束,中间的那段字符串
'SourceStr : 源字符串
'BeginStr : 开始字符串
'EndStr : 结束字符串
'WithB : 是否包含开始字符串(1代表包含0代表不包含)
'WithE : 是否包含结束字符串(1代表包含0代表不包含)
'说明:开始字符串与结束字符串一定要保证是唯一字符串
'-----------------------------------------------------------------------------
function GetMid(byval SourceStr,BeginStr,EndStr,WithB,WithE)
 dim bIndex
 dim eIndex

 bIndex = instr(SourceStr,BeginStr)
 eIndex = instr(SourceStr,EndStr)
 if bIndex <= 0 or eIndex <= 0 or eIndex - bIndex<=0 then GetMid = "":exit function
 
 if WithB = 1 then
  if WithE = 1 then
   GetMid = mid(SourceStr,bIndex,eIndex + len(EndStr) - bIndex)'包含开始字符串 包含结束字符串
  else
   GetMid = mid(SourceStr,bIndex,eIndex - bIndex)'包含开始字符串 不包含结束字符串
  end if
 else
  if WithE = 1 then
   GetMid = mid(SourceStr,bIndex + len(BeginStr),eIndex + len(EndStr) - bIndex - len(BeginStr))'不包含开始字符串 包含结束字符串
  else
   GetMid = mid(SourceStr,bIndex + len(BeginStr),eIndex - len(BeginStr) - bIndex)'不包含开始字符串 不包含结束字符串
  end if
 end if
end function
%>

<html>

<BODY bgColor=#ffffff leftMargin=0 topMargin=0 MARGINHEIGHT=0 MARGINWIDTH=0>
<!-- 开始 -->   
<%
Dim url

url="http://www.baidu.com/"
response.Write GetMidWith(getHTTPPage(url),"<input type=""submit""","</span>",1,0)
%>
<!-- 结束 -->
</body></html>

原文:http://
0 回复
1