'=====================================================================
'=                       猫七数据加密、解密类                         =
'=     Copyright (c) 2011 猫七(QQ:77068320) All rights reserverd.    =
'=              请尊重作者劳动成果，转载请保留代码的完整性             =
'=====================================================================
'= 作者：苗启源(博客:http://www.miaoqiyuan.cn)                        =
'= 讨论：http://www.miaoqiyuan.cn/p/catseven-coding
'= 最新：http://www.miaoqiyuan.cn/products/Catseven.Coding.rar
'=====================================================================
'=  文件名：Class.Catseven.Coding.asp                                =
'=  功  能：猫七数据加密、解密函数                                     =
'=====================================================================
  class Catseven_Coding
    public akey,ekey,keylen,keymax,autolen

    '类初始化
    '  akey    编码表
    '  ekey    密钥
    '  keylen  标准编码长度
    '  keymax  最大编码长度，默认1000，代表1000-数据长度必须是3位数字，即数据的长度可以为0-900
    '  autolen 如果不足，是否补全
    public sub class_initialize()
      akey   = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
      ekey   = "f67RSTUOPDp02qd34ABbMijQFxyr5szZnot89+Y/=EghkVavwuHCXWmKLJNGIcel1"
      keylen = 900
      keymax = 1000
      autolen= true
    end sub

    '函数：randkey
    '功能：创建随机字符
    '参数：rndkeylen  随机字符长度
    private function randkey(byval rndkeylen)
      dim rndnum,keymap,rstr,i
      keymap = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
      rstr = ""
      for i = 1 to rndkeylen
        randomize
        rndnum = cLng(len(keymap) - 1) * rnd() + 1
        rstr   = rstr & mid(keymap,rndnum,1)
      next
      randkey = rstr
    end function

    '函数：encode
    '功能：加密字符串
    '参数：str    要加密的字符串
    public function encode(byval str)
      dim alen,i,vstr,kstr,vkey
      str  = replace(str,"\","")
      alen = len(str)
      if alen = 0 then
        encode = ""
      else
        vstr = ""
        vkey = randkey(1)
        for i = 1 to len(str)
          kstr = mid(str,i,1)
          vstr = vstr & mid(akey,instr(ekey,kstr),1)
        next
        alen = keymax - alen
        vstr = len(alen) & vkey & randkey(9 - len(keymax)) & alen & UCase(vkey) & vstr
        alen = len(vstr)
        if keylen < alen then keylen = alen
        if keylen > keymax * 0.9 then keylen = keymax * 0.9
        vstr = mid(vstr,1,keylen)
        if alen < keylen and autolen = true then
          vstr = vstr & randkey(keylen - alen)
        end if
        encode = vstr
      end if
    end function

    '函数：decode
    '功能：解密字符串
    '参数：str    要解密的字符串
    public function decode(byval str)
      dim alen,i,vstr,kstr,vkey
      alen = mid(str,1,1)
      vkey = mid(str,2,1)
      if not isnumeric(alen) then
        decode = ""
      else
        alen = mid(str,11 - alen,alen)
        if not isnumeric(alen) then
          decode = ""
        else
          alen = keymax - alen + 1
          str = mid(str,11,alen)
          if mid(str,1,1) = UCase(vkey) then
            vstr = ""
            str = mid(str,2)
            for i = 1 to len(str)
              kstr = mid(str,i,1)
              vstr = vstr & mid(ekey,instr(akey,kstr),1)
            next
            decode = vstr
          else
            decode = ""
          end if
        end if
      end if
    end function
  end class

使用的时候比较简单，只支持英文加密，所以使用的时候，请配合base64函数(相关代码：http://www.miaoqiyuan.cn/p/tag/base64)使用。加密的时候用encode。

  set a = new Catseven_Coding
  a.autolen = true
  a.keylen  = 150
  response.write a.encode("5qyi6L+O5ZKM5oiR6K6o6K6677yM5pys5paH5Y6f5paH5Zyw5Z2A77yaaHR0cDovL3d3dy5taWFvcWl5dWFuLmNuL3AvQ2F0c2V2ZW4tQ29kaW5n")

'base64编码后的字符

解密的时候直接用decode。

  set a = new Catseven_Coding
  response.write a.decode("3kfRpeT888KcNaVB4lHcf3UchVDB3BhB3BBCCaUcKadcKuycmBAcKuycfawcfMRCCauuyDL9Jhv4POPOaciu1Yv91/cO1Yx426x4PRvXMYL9MtMf1QiXMksu1cgkwbbM5c2IZDXHMqcZSnkCb4C6LP")

'解码后，为base64编码

可以指定ekey指定对照表

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

  '=====================================================================
  '  意见反馈地址：http://www.miaoqiyuan.cn/p/asp-pinyin
  '  最新数据库：http://www.miaoqiyuan.cn/Products/update/pinyin.db.zip
  '=====================================================================
  '函数名：GET_PINYIN
  '  功能：返回拼音
  '  参数：word  - 要转换的汉字，只支持一个汉字
  Function GET_PINYIN(word)
    if asc(word) > 0 and asc(word) < 128 then
      GET_PINYIN = word
      exit function
    end if
    if word = "，" or word = "。" or word = "、" or word = "’" or word = "‘"  or word = "“"  or word = "”" or word = "：" then
      GET_PINYIN = word
      exit function
    end if
    set pydb = server.createobject("ADODB.Connection")
    pydb.open "provider=microsoft.jet.oledb.4.0;data source=" & Server.Mappath("py.db")
    set pyrs = pydb.execute("select pinyin from PinYin where content like '%" & word & "%'")
    if pyrs.eof then
      GET_PINYIN = "__"
    else
      GET_PINYIN = pyrs(0)
    end if
    pyrs.close
    set pyrs = nothing
    pydb.close
    set pydb = nothing
  End Function

  dim str,tmp
  str = "猫七，一个不知名程序员，博客地址是：http://www.miaoqiyuan.cn/"
  tmp = ""
  for i = 1 to len(str)
    tmp = tmp & mid(str,i,1)
  next
  response.write tmp

而且出现在一个笑话网站上，那么程序员到底能不能买到房子呢？

'===============================================================================
' 程序员买房 by 苗启源
'===============================================================================
'    google很给力的笔试题：现在北京有一套房子，价格200万，假设房价每年上涨10%，一个软件工程师每年固定能赚40万。如果他想买这套房子，不贷款，不涨工资，没有其他收入，每年不吃不喝不消费，那么他需要几年才能攒够钱买这套房子？
'     A, 5年
'     B, 7年
'     C, 8年
'     D, 9年
'     E, 永远买不起
'===============================================================================

function buyHouse(byval iyear)
  dim price,rise,wage
  price = 200
  rise  = 0.1
  wage  = 40
  buyHouse = outStatus(iyear,cLng(price * (1 + rise)^iyear),wage * iyear)
end function

function outStatus(byval iyear,byval price,byval rise)
  dim dif
  dif = price - rise
  'debug
  wscript.echo  " ==> 第" & iyear & "年" &_
           " 房价:" & price & "万" &_
           " 存款：" & rise & "万" &_
           " 还差：" & dif & "万"
  if dif > 0 then
    outStatus = "失败"
  else
    outStatus = "成功"
  end if
end function

'假如程序员工作时间35年(25毕业、60退休)
for iyear = 1 to 35
  status = buyHouse(iyear)
  if status = "成功" then exit for
  wscript.echo " ==>程序员在工作第" & iyear & "年时，买房结果："  & status
next

运算结果是：买不起房子的不用抱怨了，如果房价不降，年薪40万不吃不喝，买房子也没门。

附上源码和测试：

一直努力工作，似乎第八年似乎买房就快买到房子了(差109万)，第九年以后，长时间买不起房子也就称习惯了，而且里买到房子的目标越来越远了。到50岁的时候，不禁要感慨一下。前一个25年在大学荒废了，后一个25年在一直活在买房的幻想。大半生过去了，不吃不喝不生病，买房还差1000多万。

本程序仅是按题目而写，当然房价会降的，我们买房还是有希望的。

  function getSessionPath()
    t = ""
    d = split(Request.Servervariables("SCRIPT_NAME"),"/")
    for i = 0 to ubound(d) - 1
      if t = "" then
        t = d(i)
      else
        t = t & "__" & d(i)
      end if
    next
    if t <> "" then
      getSessionPath = t & "_"
    else
      getSessionPath = ""
    end if
  end function

  ses_start = getSessionPath()
  session(ses_start & "login") = "admin"

目录不同，session前缀也不同，就避免了同一个空间，仿多个同一样的站点引发的安全问题了。

  '加载模板
  '对于模板，不了解的，可以参考我以前写过的文章，当然也可以用任何asp的模板系统
  set p = new MYW3_TPL
  p.LoadTpl "tpl/chengyu.html"
  p.assign "Title","猫七"
  p.assign "WebHome",WebHome
  p.assign "WebSkin",WebSkin

  '/index.html
  url = "index"
  '/home/index.html
  'url = "home::index"
  '/home/1/2/333.html
  'url = "home::1::2::333"
  '生成静态
  ‘使用FileDB类，超级简单
  set f = new FileDB
  f.DBPath = "/"
  f.idxKey = url
  f.save(p.outHtml)

需要对FileDB的类做一下小的修改

Private Function getPath()
    Dim tmp
    getPath = replace(idxKey,"::","/") & ".html"
  End Function

Class FileDB
  Dim fso,IdxKey,DBPath
  Private Sub Class_Initialize
    Set fso = Server.CreateObject("Scripting.FileSystemObject")
    idxKey = "demo::test"
    DBPath = "DataCenter/File_DB/"
  End Sub

  Private Function getPath()
    Dim tmp
    getPath = replace(idxKey,"::","/") & ".html"
  End Function

  Private Function checkFile(byref fname)
    fname = Server.Mappath(DBPath & getPath())
    checkFile = fso.fileexists(fname)
  End Function

  Private Sub createPathName(byval idxKey)
    Dim TmpPa
    TmpPa = Server.Mappath(DBPath & idxKey)
    if not fso.folderexists(TmpPa) then
      if instr(idxKey,"\") > 0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      fso.createfolder(TmpPa)
    end if
  End Sub

  Public Function getTxt()
    if checkFile(fname) then
      set Txt = fso.getfile(fname)
      if Txt.size = 0 then
        Tmp = ""
      else
        Tmp = fso.opentextfile(fname).readall
      end if
      set Txt = Nothing
      getTxt = Tmp
    else
      getTxt = ""
    end if
  End Function

  Public Function remove()
    if checkFile(fname) then
      fso.deletefile fname
    end if
  End Function

  Public Function Save(byval content)
    if checkFile(fname) then
      set fpo = fso.opentextfile(fname,2)
    else
      idxKey = replace(idxKey,"::","\")
      if instr(idxKey,"\")>0 then Call createPathName(left(idxKey,instrrev(idxKey,"\")-1))
      set fpo = fso.createtextfile(fname)
    end if
    fpo.write content
    fpo.close
    set fpo = nothing
  End Function
End Class

因为时间比较紧，而且代码比较简单，就不加注释了，实际就是简化了文本文件的操作方法。

<% Server.ScriptTimeOut=10000 %>
<%
  '数据库链接代码

  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"

  conn.open constr
  set rs = server.createobject("ADODB.Recordset")
  '得到所有没有转换的数据
  rs.open "select * from sendlog where send_mob not like '%::%'",conn,3,2
  do while not rs.eof
    'FileDB 数据存放路径，日期::MD5(ID)
    idxStr = split(Rs("send_date")," ")(0) & "::" & md5(Rs("send_id"))
    fdb.IdxKey = idxStr
    fdb.Save(Rs("send_mob"))
    Rs("send_mob") = idxStr
    rs.update
    rs.movenext
  loop
  rs.close
  conn.close

  '数据库压缩过程，不是重点，再次不再多述
  compactdata(DataPath)
%>
减肥成功，所有数据转存到FileDB中。

执行一下，所有数据就转存好了，读取的时候很简单，指定了 idxStr，用getTxt()即可得到内容。

  set fdb = new FileDB
  fdb.DBPath = "../DataCenter/sms_DB/"
  '../DataCenter/sms_DB/aaa/1111.txt
  fdb.idxKey = "aaa::1111"
  str1 = fdb.getTxt()
  '../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.idxKey = "bbb:ccc::ddd:eee"
  str2 = fdb.getTxt()
  '删除 ../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt
  fdb.remove()
  '因为文件不存在，得到的值就是空字符串
  str3 = fdb.getTxt()
  '将内容保存到../DataCenter/sms_DB/bbb/ccc/ddd/eee.txt，因为不存在则创建，如果存在，则修改。
  fdb.save("11111")

2010年10月24日更新小Bug，修复了idxKey 定于数据存放在根目录，就会报错的错误

  class bin2txt
    dim adostream
    private sub class_initialize
      set adostream = server.createobject("ADODB.Stream")
      adostream.type = 1
      adostream.mode = 3
    end sub

    public sub open(fn)
      adostream.open
      adostream.LoadFromFile fn
    end sub

    public function getHex(t)
      dim tmp,hexstr,binstr
      binstr = adostream.read()
      for i = 1 to lenB(binstr)
        tmp = hex(ascB(midB(binstr,i,1)))
        if len(tmp) = 1 then tmp = "0" & tmp
        hexstr = hexstr & tmp & t
      next
      getHex = hexstr
    end function

    public function getOct(t)
      dim tmp,octstr,binstr
      binstr = adostream.read()
      for i = 1 to lenB(binstr)
        tmp = (ascB(midB(binstr,i,1)))
        if len(tmp) = 2 then tmp = "0" & tmp
        if len(tmp) = 1 then tmp = "00" & tmp
        octstr = octstr & tmp & t
      next
      getOct = octstr
    end function

  end class

使用方法，很简单，代码如下：

  set f = new bin2txt
  f.open server.mappath("sms/1.jpg")
  response.write f.getHex()

彩信添加桢也添加玩函数

'addpage
'pid:帧编号
'showtime:帧展示时间
function addpage(pid,showtime,ttype,tfile,ptype,pfile,mtype,mfile)
  addpage = "&d" & pid & "=" & showtime
  if ttype <> "" and ptype <> "" then
    f.open server.mappath(tfile)
    addpage = addpage & "&tt" & pid & "=" & ttype &_
                        "&tv" & pid & "=" & f.getHex()
  end if
  if ptype <> "" and ptype <> "" then
    f.open server.mappath(ptype)
    addpage = addpage & "&pt" & pid & "=" & ptype &_
            "&pv" & pid & "=" & f.getHex()
  end if
  if mtype <> "" and mtype <> "" then
    f.open server.mappath(mtype)
    addpage = addpage & "&mt" & pid & "=" & mtype &_
            "&mv" & pid & "=" & f.getHex()
  end if
end function

set f = new bin2txt
f.open server.mappath("sms/title.txt")
sendstr = "id=***&pwd=***&subject=" & f.getHex()
sendstr = sendstr & addpage(1,5,"txt","sms/1.txt","jpg","sms/1.jpg","","")
sendstr = sendstr & addpage(2,5,"txt","sms/2.txt","jpg","sms/2.jpg","","")
response.write openApi("http://118.144.76.79:8080/mmsServer/sendMms",sendstr)

  '作者：苗启源(Miaoqiyuan.cn)
  '函数：getCatagory
  '功能：获得分类列表
  '参数：cat_arr     -> 分类数组(Rscordset:id:分类编号,pid:上级分类,classname:分类名称,childs:子分类)
  '       按此顺出些sql语句，用getRows获取得到的数据
  '      cat_pid     -> 上级分类编号
  '      cat_childs  -> 下级分类编号
  '      cat_select  -> 选择的分类
  '      cat_dir     -> 分类级别
  '返回：返回分类列表(Option)
  function getCatagory(byval cat_arr,byval cat_pid,byval cat_childs,byval cat_select,byval cat_dir,byval format)
    dim i,tmp
    if cat_pid=0 and format="option" then
      %><option value="0">根目录</option><%
    end if
    if isArray(cat_arr) then
      for i=0 to ubound(cat_arr,2)
        if cat_arr(1,i) = cat_pid and instr("," & cat_childs & ",","," & cat_arr(0,i) & ",") = 0 then
          if format = "option" then
            %><option value="<%=cat_arr(0,i)%>" <%if cat_arr(0,i) = cat_select then response.write "selected"%>><%=cat_dir%>┣<%=cat_arr(2,i)%></option><%
          else
            '<li>{$cat.dir}┣<a href="?act=edt&id={$cat.id}&type=product">{$cat.name}</a></li>
            tmp = format
            if instr(tmp,"{$cat.dir}")>0 then tmp = replace(tmp,"{$cat.dir}",cat_dir)
            if instr(tmp,"{$cat.id}")>0 then tmp = replace(tmp,"{$cat.id}",cat_arr(0,i))
            if instr(tmp,"{$cat.pid}")>0 then tmp = replace(tmp,"{$cat.pid}",cat_arr(1,i))
            if instr(tmp,"{$cat.name}")>0 then tmp = replace(tmp,"{$cat.name}",cat_arr(2,i))
            if instr(tmp,"{$cat.childs}")>0 then tmp = replace(tmp,"{$cat.childs}",cat_arr(3,i))
            response.write tmp
          end if
          call getCatagory(cat_arr,cat_arr(0,i),cat_childs,cat_select,cat_dir & "┃",format)
        end if
      next
    end if
  end function