set http=Server.createobject("MSXML2.XMLHTTP") Http.open "GET",url,false '打开xmlhttp Http.send() '发送请求 if Http.readystate>4 then exit function end if getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") '返回结果(一般是字节流)，并将字节流转换为字符串 set http=nothing '释放xmlhttp
详细应用见下面的完整代码
三、完整代码（文件名：searchi_bd.asp）
% option explicit Dim wd,pn wd = Request("wd") pn = Request.QueryString("pn") '开始错误处理 On Error Resume Next If Err.Number > 0 Then Response.Clear '显示错误信息给用户 Response.Write "p align='center' >font size=3> 出错了，请重新打开百度搜索./font>/p>" end if %> HTML> HEAD> TITLE>百度搜索--%=wd%>/TITLE> /HEAD> STYLE type=text/css> !-- body,td{font-family:arial} TD{FONT-SIZE:9pt;LINE-HEIGHT:18px} .cred{color:#FF0000} //--> /STYLE>
BODY leftmargin="0" topmargin="3" marginwidth="0" marginheight="0"> table align="center" width="98%" cellspacing="0" cellpadding="0" border="0" bgcolor="#ffffff" > tr> form name="f1" method="post" action="searchi_bd.asp"> td width=150 height=50> 你的LOGO /td> td align="left"> input name=wd size="40" maxlength="100" title="输入关键字,然后Let's Searching..." value="%=wd%>"> input type="submit" value=" 百度搜索 "> /td>/form>/tr> /table> % Dim strUrl,strTmp_bd,strInfo,strPage,strPageSum_bd,strQtime_bd Dim bNoResult_bd,regEx,patrn '百度查询字符串 strUrl = "http://www.baidu.com/s?ie=gb2312wd="wdam ... pn"cl=3" '开始采集 strTmp_bd = GetHTTPPage(strUrl) If InStr(strtmp_bd,"未找到和您的查询")>0 Then bNoResult_bd=1 End If
'截取"分页区"部分的内容 strPage = strCut(strTmp_bd,"br clear=all>","br>",2) strPage = Replace(strPage,"href=s?","href=searchi_bd.asp?") '结果数量与用时 strPageSum_bd=strCut(strtmp_bd,"找到相关网页约","篇",2) if not IsNumeric(strPageSum_bd) then strPageSum_bd=strCut(strtmp_bd,"找到相关网页","篇",2) end if strQtime_bd=strCut(strtmp_bd,"用时","秒",2) Set strTmp_bd=nothing
div align="center">font size=-1> 程序更新请到这里span class="cred">(知识分享论坛)/span>查看/font> /div> /BODY> /HTML>
% '采集函数 Function getHTTPPage(url) On Error Resume Next dim http set http=Server.createobject("MSXML2.XMLHTTP") Http.open "GET",url,false Http.send() if Http.readystate>4 then exit function end if getHTTPPage=bytesToBSTR(Http.responseBody,"GB2312") set http=nothing If Err.number>0 then Response.Write "div align='center'>b>服务器获取文件内容出错/b>/div>" Err.Clear End If 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
'截取字符串,1.包括前后字符串，2.不包括前后字符串 Function strCut(strContent,StartStr,EndStr,CutType) Dim S1,S2 On Error Resume Next select Case CutType Case 1 S1 = InStr(strContent,StartStr) S2 = InStr(S1,strContent,EndStr)+Len(EndStr) Case 2 S1 = InStr(strContent,StartStr)+Len(StartStr) S2 = InStr(S1,strContent,EndStr) End select If Err Then strCute = "p align='center' >font size=-1>截取字符串出错./font>/p>" Err.Clear Exit Function Else strCut = Mid(strContent,S1,S2-S1) End If End Function
