標簽歸檔:ASP

用FileDB快速開發生成靜態系統

最近要用到一套ASP生成靜態的小系統,雖然說程序簡單,但是寫起來還是比較繁瑣的,正好前幾天寫過一個:ASP文件存儲方案(http://www.okfdzs1809.com/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.okfdzs1809.com)
'==============================================================
  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
%>