利用MSXML2_XmlHttp和Adodb_Stream获取网页的源程序

来源：互联网发布：世界濒危动物数据编辑：程序博客网时间：2024/05/23 16:29

www.u8686.com-信息发布平台

<%@LANGUAGE="VBSCRIPT" CODEPAGE="936"%>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312" />
<title>无标题文档</title>
</head>

<body>
<%
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 HtmlSave(Url,FileSavePath)
  Dim Fso,Str
  HtmlSave=false
  Str=GetHttpPage(Url)
  If Str="" Then Exit Function
  If FsObject1=0 Then
   Set Fso = server.CreateObject("scripting."&"filesystemobject")
   Set Fso = Fso.CreateTextFile(Server.mappath(FileSavePath))
   Fso.Write Str
   Fso.Close:Set Fso=NoThing
  Else
   Set Fso = Server.CreateObject("ADODB.Stream")
   Fso.Type = 2
   Fso.Open
   Fso.Charset = "GB2312"
   Fso.Position = Fso.Size
   Fso.WriteText Str
   Fso.SaveToFile FileSavePath,2
   Fso.close:Set Fso=Nothing
  End If
  HtmlSave=True
  Str = Empty
  Fso = Empty
End Function
Function GetHttpPage(HttpUrl)
  dim http
  Set http=server.createobject("MSXML2.XmlHttp")
  http.open "POST",HttpUrl,false
  On Error Resume Next
  Http.send()
  If Http.readystate<>4 Then Exit Function
  GetHttpPage=BytesToBstr(Http.ResponseBody,"GB2312")
  If InStr(Lcase(getHTTPPage), "charset=utf-8") Then GetHttpPage=Http.responseText
  Set http=nothing
  if err.number<>0 Then err.Clear
  Http=Empty
End Function

%>
<%
'response.Write GetHttpPage("http://www.u8686.com")
call HtmlSave("http://www.u8686.com","u8686.txt")%>
</body>
</html>