WinHttpRequest使用方法,WinHttpRequest演示实例

最近经常需要开发API,Microsoft.XMLHttp、MSXML2.XMLHTTP 等组件不能满足我的要求(主要是不能自定义header等信息),通过查资料发现了WinHttp.WinHttpRequest.5.1,但是关于winhttprequest的资料太少了。通过这几天摸索,勉强了解了WinHttpRequest使用方法

WinHttp.WinHttpRequest是一个非常实用的一个组件。作为站长,就会经常关注自己网站的流浪,今天以 免登陆获得cnzz统计信息 和 免登陆获得51.la统计信息 为例,一起了解下WinHttpRequest的使用方法。CNZZ会员系统没有使用验证码,而51.la使用了验证码,针对两种不同的系统,我们分两种方法讨论。

实时获取CNZZ统计信息 ASP版
WinHttp.WinHttpRequest采集无验证码会员系统实例
实时获取51.la统计信息 ASP版
WinHttp.WinHttpRequest采集有验证码会员系统实例

实时获取CNZZ统计信息 ASP版

  
  '=====================================================================
  '=            WinHttpRequest演示实例 - 实时获取CNZZ统计信息          =
  '=     Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd.    =
  '=              请尊重作者劳动成果,转载请保留代码的完整性           =
  '=====================================================================
  '= 作者:苗启源(博客:http://www.miaoqiyuan.cn)                       =
  '= 讨论:http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo
  '= 最新: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,"&nbsp;","")
    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

实时获取51.la统计信息 ASP版

  '=======================================================================
  '=            WinHttpRequest演示实例 - 实时获取51.la统计信息            =
  '=     Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd.      =
  '=              请尊重作者劳动成果,转载请保留代码的完整性               =
  '=======================================================================
  '= 作者:苗启源(博客:http://www.miaoqiyuan.cn)                          =
  '= 讨论:http://www.miaoqiyuan.cn/p/winhttp-winhttprequest-5-1_demo
  '= 最新:http://www.miaoqiyuan.cn/products/winhttprequest_51lademo.rar
  '=======================================================================
  '=  返回首页站点列表: winhttprequest_demo_51la.asp                     =
  '=  读取并输出验证码: winhttprequest_demo_51la.asp?act=getcode         =
  '=  显示数据验证码框: winhttprequest_demo_51la.asp?act=login           =
  '=  验证验证码并登陆: winhttprequest_demo_51la.asp?act=dologin         =
  '=======================================================================
  '=  文件名:winhttprequest_demo_51la.asp                               =
  '=  功  能:免登陆查看51.la 网站流量统计信息                             =
  '=======================================================================

  Dim HttpID,AppName,CNZZ_User,CNZZ_Password
  HttpID        = 0
  AppName       = "app_51.la_demo"                      '应用程序名前缀,防止感染其他程序Application变量
  La51_User     = "myw3demo"                            '51.la账号
  La51_Password = "la51test"                            '51.la密码

  '函数名:OpenHttp
  '功  能:创建Http请求,并返回服务器处理结果
  '参  数:url          请求地址
  '        PostData     请求数据包,如果是Get请求,请以SENDTYPE=GET开头
  '        &strlocation 如果是服务器重定向网址,则返回重定向的地址
  '特  点:自动保存/共享cookies,多次请求能保存登录状态,新增二进制获取
  Function OpenHttp(byval url,byval PostData,byref strlocation)
      dim xmlhttp,xmlget,bgpos,endpos,sendtype,imgtype,isbinstr
      HttpID = HttpID + 1
      if HttpID > 10 then
        response.write "1,连接次数过多"
        response.end
      end if
      strlocation = ""
      '与CNZZ的实例对比,增加了获取验证码的功能
      sendtype = "SENDTYPE=GET"
      imgtype  = "GETTYPE=IMAGE"
      isbinstr = false
      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 or left(PostData,len(imgtype)) = imgtype then
          if left(PostData,len(sendtype)) = sendtype then
            url = url & "?" & replace(PostData,sendtype,"")
          else
            url = url & "?" & replace(PostData,imgtype,"")
            isbinstr = true
          end if
          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
        '阿江的Cookies比较变态,有3个Set-Cookie,因为这个问题,浪费了好几个小时
        If InStr(.GetAllResponseHeaders,"Set-Cookie") Then
            Application(AppName & "APIOPcookie") = getAJiangCookies(.GetAllResponseHeaders)
        End If
        if isbinstr then
          xmlget = .responseBody
        else
          xmlget = bin2str(.responseBody)
        end if
      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
  
  '函数名:getAJiangCookies
  '功  能:从http头中返回多个cookies值
  '参  数:strHeader    HTTP头
  Function getAJiangCookies(byval strHeader)
    dim tmp,ltmp,sck
    tmp = ""
    sck = "Set-Cookie:"
    for each ltmp in split(strHeader,vbCrlf)
      if left(ltmp,len(sck)) = sck then
        if tmp <> "" then tmp = tmp & ";"
        ltmp = mid(ltmp,len(sck) + 2)
        tmp = tmp & split(ltmp,"; ")(0)
      end if
    next
    tmp = tmp & "; expires=Tue, 23-Sep-2014 16:00:00 GMT; path=/"
    getAJiangCookies = tmp
  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
  
  '函数名: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
  '功  能:连接51.la并返回处理结果,如果没有登录,自动重新登录
  '参  数:act      操作名称,主要简化代码量("http://www.51.la/[ACT].asp")
  '        str      请求的数据
  Function Connect(byval act,byval str)
    dim html
    html = OpenHttp("http://www.51.la/" & act & ".asp",str,strlocation)
    '如果未登录状态,则进入登录页面
    if strlocation = "../login.asp" then
      response.redirect "?act=login"
    elseif strlocation <> "" then
      Connect = strlocation
    else
      Connect = html
    end if
  End Function
  
  '方法名:getCode
  '功  能:获取验证码
  Sub getCode()
    dim html
    Response.Expires = -9999 
    Response.AddHeader "Pragma","no-cache" 
    Response.AddHeader "cache-ctrol","no-cache" 
    Response.ContentType = "Image/BMP" 
    response.binarywrite Connect("user/vcode","GETTYPE=IMAGE")
  End Sub
  

  '方法名:Main
  '功  能:从51.la返回站点列表
  Sub Main()
    dim html,pe,pa,pm,re,ra,rm
    html = Connect("user/index","SENDTYPE=GETall=yes")
    html = notImage(html)
    html = notLink(html)
    Call OpenRegExp(re)
    Call OpenRegExp(ra)
    Call OpenRegExp(rm)
    re.pattern = "[\S\s]*点击“查看统计报表”可查看实时数据。"
    ra.pattern = "\( 合计当前显示的[\S\s]*"
    rm.pattern = "<div class=""sitelist_o"">[^<]*</div>"
    set pe = re.execute(html)
    set pa = ra.execute(html)
    set pm = rm.execute(html)
    if pe.count = 0 or pa.count = 0  or pm.count = 0 then
      response.write "对不起,51.la改版了。请访问:http://www.miaoqiyuan.cn/p/WinHttp-WinHttpRequest-5-1_DEMO 获取最新版本"
    else
      html = re.replace(html,"")
      html = ra.replace(html,"")
      html = rm.replace(html,"")
      html = "<div>" & html & "</div>"
      Call MainUI(html)
    end if
  End Sub
  
  '方法名:Login
  '功  能:获取登录界面
  Sub Login()
    dim html
    html = "<form action=""?act=dologin"" method=""POST"">" & _
           "第一次访问的时候,需要输入验证码:" & _
           "<input name=""vcode"" size=""4"" />" & _
           " <img src=""?act=getcode&timer=" & timer() & """ /> " & _
           "<input type=""submit"" value=""提交""/>" & _
           "</form>"
    Call MainUI(html)
  End Sub
  
  '方法名:doLogin
  '功  能:登录51.la
  Sub doLogin()
    dim html,vcode,sendStr
    vcode   = request("vcode")
    sendStr = "uname=" & La51_User & _
              "&upass=" & La51_Password & _
              "&vcode=" & vcode & _
              "&remb=yes"
    html = Connect("login",sendStr)
    if html = "user/" then
      response.redirect "?act=list"
    elseif instr(html,"验证码不正确") then
      Call MainUI("<a href=""?act=login"">验证码不正确,请重新登录</a>")
    else
      Call MainUI("<a href=""?act=login"">账号或密码错误,请修改配置并重新登录</a>")
    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 - 实时获取51.la统计信息</title>" & _
           "<style type=""text/css"">" & _
           ".sitelist_n{height:35px;width:620px;background:#CCC;color:#000;line-height:35px;text-align:left;text-indent:10px;font-weight:800;}" & _
           ".sitelist_s{height:35px;width:620px;color:#666;line-height:35px;font-size:13px;text-align:left;text-indent:20px;}" & _
           "</style>" & _
           "</head>" & _
           "<body><center><h1>WinHttpRequest DEMO by Miaoqiyuan.cn</h1><h2>实时获取51.la统计信息</h2><hr />" & _
           body & _
           "<hr />Copyright: miaoqiyuan.cn 2011-" & year(now) & "" & _
           "</center></body></html>"
    response.write html
  End Sub
  
  '入口
  select case request("act")
    case "getcode"
      Call getCode()
    case "login"
      Call Login()
    case "dologin"
      Call doLogin()
    case else
      Call Main()
  end select

发表评论

电子邮件地址不会被公开。 必填项已用*标注