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

<%
'==============================================================
'   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
%>

<%
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的时候，都是处理二进制文件。简单的文本，就没有必要编码咯。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

在网上搜索了一下，asp通过域名查ip需要安装一个TCPIP.DNS的组件。我下载了一个测试了一下，效率并不是很高。

一般查询域名的ip的方法是ping一下，得到一个ip。我们先用VBScript测试。

Function strCut(strContent,StartStr,EndStr,CutType)
    Dim strHtml,S1,S2
    strHtml = strContent
    On Error Resume Next
    Select Case CutType
    Case 1
        S1 = InStr(strHtml,StartStr)
        S2 = InStr(S1,strHtml,EndStr)+Len(EndStr)
    Case 2
        S1 = InStr(strHtml,StartStr)+Len(StartStr)
        S2 = InStr(S1,strHtml,EndStr)
    End Select
    If Err Then
        strCute = "0.0.0.0"
        Err.Clear
        Exit Function
    Else
        strCut = Mid(strHtml,S1,S2-S1)
    End If
End Function

Function getIP(Domain)
	Set objWShell=CreateObject("WScript.Shell")
	Set objCmd=objWShell.Exec("ping "&Domain)
	StrPResult=objCmd.StdOut.Readall()
	Set objCmd=nothing
	Set objWShell=nothing
	getIP=strCut(StrPResult,"[","]",2)
End Function

startTme=timer
Wscript.echo getIP("www.baidu.com")
wscript.echo timer-startTme

不过效率很低哦，大约三秒钟的时间才能得到结果。通过域名查ip还有一个快速的方法，nslookup，我们修改一下上边的函数：

Function strCut(strContent)
	ipsta=1
	strLineArr=split(strContent,vbCrlf)
	for each strLine in strLineArr
		if instr(strLine,":")>0 then
			getArr=split(strLine,":")
			if LCase(getArr(0))="address" then
				ipsta=1
			end if
			if ipsta=1 then
				if LCase(getArr(0))="address" then
					strCut=split(Trim(getArr(1)),",")(0)
					exit function
				end if
			end if
		end if
	next
	strCut="err"
End Function

Function getIP(Domain)
	Set objWShell=CreateObject("WScript.Shell")
	Set objCmd=objWShell.Exec("nslookup "&Domain)
	StrPResult=objCmd.StdOut.Readall()
	Set objCmd=nothing
	Set objWShell=nothing
	getIP=strCut(StrPResult)
End Function

startTme=timer
Wscript.echo getIP("www.baidu.com")
wscript.echo timer-startTme

现在速度快了，0.3秒即可搞定。vbscript是解决了，那asp通过域名查ip还是不可以的，一个最大的问题是虚拟主机一般都不给执行asp脚本运行WScript.Shell的权限，所以虚拟主机用户可以不用考虑了，TCPIP.DNS这种空间商肯定是不给用的。第二个问题也是安全问题，自己用的服务器，一般都不给web用户访问系统目录的权限，asp访问nslookup.exe的权限一般都没有？解决方法就是修改一下相关文件的权限即可。

< %
Function strCut(strContent)
	strLineArr=split(strContent,vbCrlf)
	for each strLine in strLineArr
		if instr(strLine,":")>0 then
			getArr=split(strLine,":")
			if LCase(getArr(0))="addresses" then
				strCut=split(Trim(getArr(1)),",")(0)
				exit function
			end if
		end if
	next
	strCut="err"
End Function

Function getIP(Domain)
	Set objWShell=Server.CreateObject("WScript.Shell")
	Set objCmd=objWShell.Exec(server.mappath("nslookup.exe")&" "&Domain)
	StrPResult=objCmd.StdOut.Readall()
	Set objCmd=nothing
	Set objWShell=nothing
	getIP=strCut(StrPResult)
End Function

response.write getIP("www.baidu.com")
%>

<%
Dim myRegExp

set myRegExp=New RegExp
myRegExp.Pattern = "[^a-z0-9_]"
myRegExp.Global=True

for each Req in Request.Querystring
	ReqV=Request.Querystring(Req)
	if trim(ReqV)&lt;&gt;"" then
		ReqV=replace(ReqV,"""","""""")
		Req=myRegExp.Replace(Req,"")
		Execute(Req&"="""&ReqV&"""")
	end if
next

response.write a
%>

调用很简单。比如GET提交/get_Test.asp?a=111&b=222

则直接可以使用Response.write a，输出结果为111。简单吧~

再次感谢小秦(Q48080163)提出的bug

可以看到现在首页的执行时间已经是1.8秒以上了，如果访问量太大，有可能就会导致耗资源，加入缓存是最好的解决方法。我设置的数据库表如下：

1.下载地址

         http://www.miaoqiyuan.cn/products/webzip.rar

2.程序源码

        http://www.miaoqiyuan.cn/p/webzip-code

3.使用说明

         http://www.miaoqiyuan.cn/p/webzip-demo

4.未解决问题

       ADODB.Stream读取asp文件时，如果文件结尾为%>，则%后的>会被忽略掉，现在本人暂未解决这个问题，用户可以在以%>结尾的asp文件，请在后边添加一个空格或换行符，恢复后程序即可正常使用。