ASP版WinHttpRequest实时获取和抓取CNZZ统计信息

最近经常需要开发API，Microsoft.XMLHttp、MSXML2.XMLHTTP 等组件不能满足我的要求(主要是不能自定义header等信息)，通过查资料发现了WinHttp.WinHttpRequest.5.1，但是关于winhttprequest的资料太少了。通过这几天摸索，勉强了解了WinHttpRequest使用方法。
WinHttp.WinHttpRequest是一个非常实用的一个组件。作为站长，就会经常关注自己网站的流浪，今天以免登陆获得cnzz统计信息
'===================================================================== 
'=            WinHttpRequest演示实例 - 实时获取CNZZ统计信息          = 
'=     Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd.    = 
'=              请尊重作者劳动成果，转载请保留代码的完整性           = 
'===================================================================== 
'= 作者：苗启源(博客:http://www.miaoqiyuan.cn)                       = 
'= 发布：http://www.zzzyk.com/show/b3b7e9c67b090be0.htm 
'= 最新：http://www.miaoqiyuan.cn/products/winhttprequest_demo.rar 
'===================================================================== 
'=  返回首页站点列表： winhttprequest_demo.asp                       = 
'=  返回某站统计数据： winhttprequest_demo.asp?act=data&id=[站点ID]  = 
'===================================================================== 
'=  文件名：winhttprequest_demo.asp                                  = 
'=  功  能：免登陆查看CNZZ 网站流量统计信息                          = 
'===================================================================== 
 
Dim HttpID,AppName,CNZZ_User,CNZZ_Password 
HttpID        = 0 
AppName       = "app_cnzz.com_demo"                   '应用程序名前缀，防止感染其他程序Application变量 
CNZZ_User     = "kefu@myw3.cn"                        'CNZZ账号 
CNZZ_Password = "CNZZTEST"                            'CNZZ密码 
 
'函数名：OpenHttp 
'功  能：创建Http请求，并返回服务器处理结果 
'参  数：url          请求地址 
'        PostData     请求数据包，如果是Get请求，请以SENDTYPE=GET开头 
'        &strlocation 如果是服务器重定向网址，则返回重定向的地址 
'特  点：自动保存/共享cookies，多次请求能保存登录状态 
Function OpenHttp(byval url,byval PostData,byref strlocation) 
    dim xmlhttp,xmlget,bgpos,endpos,sendtype 
    HttpID = HttpID + 1 
    if HttpID > 10 then 
      response.write "1,连接次数过多"
      response.end 
    end if 
    strlocation = ""
    sendtype = "SENDTYPE=GET"
    Set xmlhttp = Server.CreateObject("WinHttp.WinHttpRequest.5.1") 
    xmlhttp.Option(6)=0 
    With xmlhttp 
      .setTimeouts 200000,200000,200000,200000 
      if left(PostData,len(sendtype)) = sendtype then 
        url = url & "?" & replace(PostData,sendtype,"") 
        PostData = ""
        .Open "GET", url , False
      else 
        .Open "POST", url, False
      end if 
      .setRequestHeader "CONTENT-TYPE","application/x-www-form-urlencoded"
      .setRequestHeader "Content-Length",Len(PostData) 
      .setRequestHeader "Referer","http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo"
      If Application(AppName & "APIOPcookie")<>"" Then .setRequestHeader "COOKIE", Application(AppName & "APIOPcookie") 
      .Send PostData 
      If InStr(LCase(.GetAllResponseHeaders),"location:") Then
        strlocation = .GetResponseHeader("location") 
      end if 
      If InStr(.GetAllResponseHeaders,"Set-Cookie") Then
        If InStr(.getResponseHeader("Set-Cookie"),"PHPSESSID") or InStr(.getResponseHeader("Set-Cookie"),"SPSESSION") then 
          Application(AppName & "APIOPcookie") = .getResponseHeader("Set-Cookie") 
          Application(AppName & "APIOPcookie") = left(Application(AppName & "APIOPcookie"),instr(1,Application(AppName & "APIOPcookie"),";")-1) 
        End if 
      End If
      xmlget = bin2str(.responseBody) 
    End With
    set xmlhttp = nothing 
    OpenHttp = xmlget 
End Function
 
'函数名：bin2str 
'功  能：将2进制值转换为GB2312编码的字符串 
'参  数：binstr       要转换的字符 
Function bin2str(byval binstr) 
    Const adTypeBinary = 1 
    Const adTypeText = 2 
    Dim BytesStream,StringReturn 
    Set BytesStream = Server.CreateObject("ADODB.Stream") 
    With BytesStream 
    .Type = adTypeText 
    .Open 
    .WriteText binstr 
    .Position = 0 
    .Charset = "GB2312"
    .Position = 2 
    StringReturn = .ReadText 
    .close 
    End With
    Set BytesStream = Nothing
    bin2str = StringReturn 
End Function
 
'函数名：OpenRegExp 
'功  能：创建正则对象，如果已经创建，则不重复创建 
'参  数：&re       要创建的正则对象变量名称 
function OpenRegExp(byref re) 
  if not isobject(re) then 
    set re = new RegExp 
    re.ignorecase = true 
    re.global     = true 
  end if 
end function 
 
'函数名：OnlyTd 
'功  能：去掉字体样式、换行符、空格 
'参  数：html      要处理的Html代码 
function OnlyTd(byval Html) 
  Html = replace(Html,vbCrlf,"") 
  Html = replace(Html,"<br />","") 
  Html = replace(Html,"<br>","") 
  Html = replace(Html,"<br/>","") 
  Html = replace(Html,"</font>","") 
  Html = replace(Html," ","") 
  call OpenRegExp(re) 
  Html = re.replace(Html,"") 
  re.pattern = "<font([^<]*)>"
  Html = re.replace(Html,"") 
  OnlyTd = Html 
end function 
 
'函数名：NotLink 
'功  能：去掉所有链接 
'参  数：html      要处理的Html代码 
function NotLink(byval Html) 
  call OpenRegExp(re) 
  Html = replace(Html,"</a>","") 
  re.pattern = "<a([^<]*)>"
  Html = re.replace(Html,"") 
  NotLink = Html 
end function 
 
'函数名：notImage 
'功  能：去掉所有图片标签 
'参  数：html      要处理的Html代码 
function notImage(byval Html) 
  call OpenRegExp(re) 
  re.pattern = "<img([^<]*)>"
  Html = re.replace(Html,"") 
  notImage = Html 
end function 
 
'函数名：midtrim 
'功  能：去掉所有多余的空格 
'参  数：html      要处理的Html代码 
function midtrim(byval s) 
  s = trim(s) 
  s = replace(s," ","") 
  for k = 0 to 50 
    s = replace(s,"  "," ") 
  next 
  midtrim = s 
end function 
 
'函数名：Connect 
'功  能：连接CNZZ并返回处理结果，如果没有登录，自动重新登录 
'参  数：act      操作名称，主要简化代码量("http://new.cnzz.com/[ACT].php") 
'        str      请求的数据 
Function Connect(byval act,byval str) 
  dim html 
  html = OpenHttp("http://new.cnzz.com/" & act & ".php",str,strlocation) 
  '如果未登录状态 
  if instr(html,"已超时，请重新登录")>0 then 
    '重新登陆 
    login = OpenHttp("http://new.cnzz.com/user/login.php","username=" & CNZZ_User & "&password=" & CNZZ_Password & "&list=1&remuser=1",strlocation) 
    if strlocation <> "/v1/main.php?s=site_list" then 
      response.write "//账号认证失败"
    end if 
    Connect = Connect(act,str) 
  else 
    Connect = html 
  end if 
End Function
 
'方法名：getData 
'功  能：从CNZZ返回某站点数据 
Sub getData() 
  dim id,html 
  id = request("id") 
  if trim(id) = "" or not isnumeric(id) then 
    response.write "//非法请求"
  else 
    id = cLng(id) 
    html = Connect("v1/data/site_list_data","SENDTYPE=GETsiteid=" & id) 
    html = "var data_arr = " & html & ";" & _ 
           "var data_obj = document.getElementById('" & id & "_ty').getElementsByTagName('td');" & _ 
           "data_obj[5].colSpan = 1;" & _ 
           "var data_cel = data_obj[5].parentNode;" & _ 
           "data_cel.insertCell();" & _ 
           "data_cel.insertCell();" & _ 
           "var outstr = '<table width=""100%"">';" & _ 
           "data_obj[1].innerHTML = data_arr[0][0];" & _ 
           "data_obj[2].innerHTML = data_arr[0][1];" & _ 
           "data_obj[3].innerHTML = data_arr[0][2];" & _ 
           "data_obj[5].innerHTML = data_arr[1][0];" & _ 
           "data_obj[6].innerHTML = data_arr[1][1];" & _ 
           "data_obj[7].innerHTML = data_arr[1][2];" & _ 
           ""
    response.write html 
  end if 
End Sub
 
'方法名：Main 
'功  能：从CNZZ返回站点列表 
Sub Main() 
  dim html 
  html = Connect("v1/main","SENDTYPE=GETs=site_list") 
  html = onlyTd(html) 
  html = notlink(html) 
  html = notImage(html) 
  Call OpenRegExp(re) 
  html = replace(html,"获取代码 | 设置 | 清零 | 删除","-") 
  html = replace(html,"cellspacing=""0"" cellpadding=""0""","cellspacing=""1"" cellpadding=""1""") 
  re.pattern = "<span style=""float:right;padding-top:5px; padding-left:8px;""></span></div>       </div>(.*)<tr>              <td height=""40"" colspan=""5"" style=""text-align:center;"">如希望继续添加站点，请点击此处"
  set p = re.execute(html) 
  if p.count > 0 then 
    MainUI p(0).submatches(0) 
  else 
    response.write "对不起，CNZZ改版了。请访问：http://www.miaoqiyuan.cn/p/WinHttp-WinHttpRequest-5-1_DEMO 获取最新版本"
  end if 
End Sub
 
'方法名：MainUI 
'功  能：友好的显示处理结果 
'参  数：body     输出正文内容 
Sub MainUI(byval body) 
  dim html 
  body = midtrim(body) 
  html = "<html>" & _ 
         "<head><meta http-equiv=""Content-Type"" content=""text/html;charset=gb2312"">" & _ 
         "<title>WinHttpRequest DEMO by Miaoqiyuan.cn - 实时获取CNZZ统计信息</title>" & _ 
         "<script type=""text/javascript"">" & _ 
         "function site_data(id){var s = document.createElement('script');s.src = '?act=data&id=' + id;document.getElementsByTagName('head')[0].appendChild(s);}" & _ 
         "</script>" & _ 
         "<style type=""text/css"">" & _ 
         ".list_box{width:900px;background:#666;};" & _ 
         ".list_box td,.list_box th{background:#FFF;line-height:25px;text-align:center;};" & _ 
         ".tr-bg4 td,.tr-bg4 th{background:#666;line-height:25px;};" & _ 
         "</style>" & _ 
         "</head>" & _ 
         "<body><center><h1>WinHttpRequest DEMO by Miaoqiyuan.cn</h1><h2>实时获取CNZZ统计信息</h2><hr />" & _ 
         body & _ 
         "</table><hr />Copyright: miaoqiyuan.cn 2011-" & year(now) & "" & _ 
         "</center></body></html>"
  response.write html 
End Sub
 
'入口 
select case request("act") 
  case "data"
    Call getData() 
  case else 
    Call Main() 
end select