标签归档:ASP

用FileDB快速开发生成静态系统

最近要用到一套ASP生成静态的小系统,虽然说程序简单,但是写起来还是比较繁琐的,正好前几天写过一个:ASP文件存储方案(http://www.miaoqiyuan.cn/p/asp-filedb),用改类,可以直接快速开发生成ASP的系统。

  '加载模板
  '对于模板,不了解的,可以参考我以前写过的文章,当然也可以用任何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

ASP文本存储方案-FileDB

四月份做个一个短信系统,当时为了节省成本(使用万网的空间,不带SQL数据库空间便宜),使用了ASP+Access开发,最近需要升级,增加一个短信接口。发现现在Access的数据库竟然有170MB。我的天啊,因为查询比较少,不是很耗资源,所以没有检查出来。
仅仅六个月,数据库竟然到了170MB。随着客户业务的增长,可能再过六个月就要到500MB了,真恐怖。主要占空间大小的,就是存储的短信的发送号码,思考再三,决定将所有的保存到文本文件中。于是写下了一个暂时成为FileDB的asp类。

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 定于数据存放在根目录,就会报错的错误

ASP版本 文件转十六进制

最近接了一个彩信接口的网站,需要将 文本文件、图片文件 转换成 HexString,通过Form提交,.net、php、javascript的函数网上一抓一大把,asp的却不好找,今天我就来写一个asp版本的hexstring转换函数,为了方便以后用,直接写成类。

  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)

新写的一个xmlClass

新写的xmlClass,有些简陋,不过常用的功能都可以直接调用了。

<%
'==============================================================
'   xmlClass v1.10.0617 by CatSeven
'==============================================================
'   文件:xmlClass.asp
'   功能:常用的XML处理
'   作者:苗启源(http://www.miaoqiyuan.cn)
'==============================================================
  class xmlClass
    Dim xmlobj
    
    Public Sub Class_Initialize
      set xmlobj = Server.CreateObject("Microsoft.XMLDOM")
    End Sub
    
    Public Sub Class_Terminate
      set xmlobj = Nothing
    End Sub
    
    '功能:从文件加载XML
    'f -> file 要保存的XML文件
    '     web://aaa.xml     根目录下的 myw3.xml
    '     path://myw3.xml   当前目录下的 myw3.xml
    '     E:/web/www/myw3.xml
    '     http://localhost/myw3.xml
    Public Sub Load(byval f)
      f = Mappath(f)
      xmlobj.load f
    End Sub
    
    '功能:将当前的数据保存到XML问及那
    'f -> file 要保存的XML文件
    '     web://aaa.xml     根目录下的 myw3.xml
    '     path://myw3.xml   当前目录下的 myw3.xml
    '     E:/web/www/myw3.xml
    '     http://localhost/myw3.xml
    Public Sub Save(byval f)
      f = Mappath(f)
      xmlobj.save f
    End Sub
    
    '功能:通过标签获取节点列表
    '参数:tag -> TagName
    '返回:符合条件的节点列表
    Public Function getTags(byval tag)
      dim p
      set p = xmlobj.getElementsByTagName(tag)
      set getTags = p
    End Function
    
    '功能:通过xPath获取节点列表
    '参数:str -> xpath 字符串
    '返回:符合条件的节点列表
    Public Function xPath(byval str)
      dim p
      set p = xmlobj.selectNodes(str)
      set xPath = p
    End Function
    
    '功能:设置节点属性
    '参数:obj -> 要设置属性的节点
    '      othervalue -> 属性值:比如 a=1&b=2  ==> <xxx a="1" b="2" />
    Public Sub setNode(byref obj,byval othervalue)
      dim valArr
      valArr = split(othervalue,"&")
      for i = 0 to ubound(valArr)
        if instr(valArr(i),"=")>0 then
          valDB = split(valArr(i),"=")
          obj.setAttribute valDB(0),valDB(1)
        end if
      next
    End Sub
    
    '功能:设置节点属性
    '参数:obj -> 节点列表,必须是一个列表,且只为列表中的第一项添加子节点。一般为:getTags,xPath返回的节点列表。
    '      xmlname -> 属性名。
    '      xmlvalue-> 属性值。
    Public Sub setAttribute(byval obj,byval xmlname,byval xmlvalue)
      for i = 0 to obj.length - 1
        obj(i).setAttribute xmlname,xmlvalue
      next
    End Sub
    
    '功能:删除当前节点
    '参数:obj -> 删除当前节点
    Public Sub Remove(byval obj)
      if obj.length>0 then obj(0).parentNode.removeChild obj(0)
    End Sub
    
    '功能:添加一个新的节点
    '参数:obj -> 节点列表,必须是一个列表,且只为列表中的第一项添加子节点。一般为:getTags,xPath返回的节点列表。
    '      nodename -> 节点名称(tagName)
    '       xmlname -> 索引属性。如果在当前文件中有节点名相同,且属性相同的节点,则不会新增节点
    '      valuearr -> 索引属性的值,必须是一个一元数组。
    '      othervalue -> 传递到setNode的属性,请参照 Public Sub setNode
    Public Sub Append(byval obj,byval nodename,byval xmlname,byval valuearr,byval othervalue)
      if obj.length<1 then Exit Sub
      for i = 0 to ubound(valuearr)
        if trim(valuearr(i))<>"" then
          if xPath("//"&nodename&"[@"&xmlname&"='"&valuearr(i)&"']").length=0 then
            set newNode = xmlobj.CreateElement(nodename)
            newNode.setAttribute xmlname,valuearr(i)
            setNode newNode,otherValue
            obj(0).appendChild(newNode)
          end if
        end if
      next
    End Sub
    
    '功能:获取节点属性列表
    '参数:obj -> 节点列表,必须是一个列表,且只为列表中的第一项添加子节点。一般为:getTags,xPath返回的节点列表。
    '      xmlname -> 属性名。
    '返回:一元数组,包含了所有的属性名
    Public Function getAttribute(byval obj,byval xmlname)
      dim Arr
      redim Arr(obj.length - 1)
      for i = 0 to obj.length - 1
        Arr(i) = obj(i).getAttribute(xmlname)
      next
      getAttribute = Arr
    End Function
    
    '功能:获取文件的路径
    'f -> file 要保存的XML文件
    '     web://aaa.xml     根目录下的 myw3.xml
    '     path://myw3.xml   当前目录下的 myw3.xml
    '     E:/web/www/myw3.xml
    '     http://localhost/myw3.xml
    '返回:文件的路径
    Private Function Mappath(byval f)
      if instr(f,"web://")>0 then
        f = replace(f,"web://","/")
        f = server.mappath(f)
      elseif instr(f,"path://")>0 then
        f = replace(f,"path://","")
        f = server.mappath(f)
      end if
      if left(LCase(f),7)<>"http://" then f = "file://" & f
      Mappath = f
    End Function
    
  end class
%>

ASP也能处理JSON数据

ASP也能处理JSON数据?呵呵,刚才在Pjblog论坛上看到一个兄弟写的文章,没有测试,不过理论上一定是可以的~ 太晚了,不测试了。
以前处理JSON太麻烦了,输出还好说,循环一下就可以了,解析真的很头疼。所以遇到 这种问题API问题,一般都是XML处理,不太喜欢,很麻烦。

<%
Dim sc4Json 
Sub InitScriptControl
Set sc4Json = Server.CreateObject("MSScriptControl.ScriptControl")
    sc4Json.Language = "JavaScript"
    sc4Json.AddCode "var itemTemp=null;function getJSArray(arr, index){itemTemp=arr[index];}"
End Sub 

Function getJSONObject(strJSON)
    sc4Json.AddCode "var jsonObject = " & strJSON
    Set getJSONObject = sc4Json.CodeObject.jsonObject
End Function 

Sub getJSArrayItem(objDest,objJSArray,index)
    On Error Resume Next
    sc4Json.Run "getJSArray",objJSArray, index
    Set objDest = sc4Json.CodeObject.itemTemp
    If Err.number=0 Then Exit Sub
    objDest = sc4Json.CodeObject.itemTemp
End Sub

Dim strTest
strTest = "{name:""alonely"", age:24, email:[""ycplxl1314@163.com"",""ycplxl1314@gmail.com""], family:{parents:[""父亲"",""母亲""],toString:function(){return ""家庭成员"";}}}"
Dim objTest
Call InitScriptControl
Set objTest = getJSONObject(strTest)
%>
<%=objTest.name%>的邮件地址是< %=sc4Json.Eval("jsonObject.email[0]")%><br />共有邮件地址< %=objTest.email.length%>个<br />
<%
Dim father
getJSArrayItem father, objTest.family.parents, 0
Response.Write father
%>

ASP的Base64加密解密

JS有Base64.js,PHP内建Base64支持,ASP处理Base64数据就没有那么幸运了,既没有Base64.asp,也没有内建的函数,这可怎么办?

ASP一般用到Base64的时候,都是处理二进制文件。简单的文本,就没有必要编码咯。ASP处理二进制又是一个弱项,有没有好的方法呢?xml中的bin.base64也许可以拿来用用。

'调用xml的编码,用于参照
function Base64Encode(strData)
    dim objAds,objXd
    set objAds=createobject("adodb.stream")
    objAds.Type=2
    objAds.charset="unicode"
    objAds.mode=3
    call objAds.open()
    objAds.writeText strData
    objAds.Position=0
    objAds.Type=1
    'objAds.Position=2

    set objXd=createobject("msxml.domdocument")
    call objXd.loadXml("<root/>")
    objXd.DocumentElement.DataType="bin.base64"
    objXd.DocumentElement.NodeTypedValue=objAds.read()
    Base64Encode=objXd.DocumentElement.text
end function

function Base64Decode(strData)
    dim objXd
    set objXd=createobject("msxml.domdocument")
    call objXd.loadXml("<root/>")
    objXd.DocumentElement.DataType="bin.base64"
    objXd.DocumentElement.text=strData
    Base64Decode=objXd.DocumentElement.NodeTypedValue
end function