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
