ASP设计模式范例/技术

做法是根据数据库结构，生成数据模型层、数据访问层和商业逻辑层的代码，现在已经实现到数据访问层了，商业逻辑层上用表单验证类严格控制输入

== 一，封装常用的类 ==

1，封装数据库访问:大部分ASP应用，都离不开对数据库的访问及操作，所以，对于数据库部分的访问操作，我们应该单独抽象出来，封装成一个单独的类。如果所用语言支持继承，可以封装一个这样的类，然后在数据操作层继承即可。下面是我写的一个ACCESS数据库访问的类，针对ACCESS作了优化，不过因为缺少足够的应用测试，可能仍然存在未知的bug及应用限制，主要代码如下：
{{{
<%
Class Oledb
Private IDataPath
Private IConnectionString
Private Conn
Private Cmd
Private Param
Private Rs
Public Property Let DataPath(ByVal Value)
IDataPath = Value
IConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(IDataPath)
End Property
Public Property Get DataPath()
DataPath = IDataPath
End Property
Public Property Let ConnectionString(ByVal Value)
IConnectionString = Value
End Property
Public Property Get ConnectionString()
ConnectionString = IConnectionString
End Property
Public Function OpenConn()
If Conn.State = adStateClosed Then
Conn.Open ConnectionString
End If
Set OpenConn = Conn
End Function
Public Function Insert(ByVal Sql, ByVal Values)
OpenConn()
Rs.Open Sql, Conn, 3, 3, adCmdText
Rs.AddNew
Dim i, l
l = UBound(Values)
For i = 1 To l + 1
Rs(i) = Values(i - 1)
Next
Rs.Update
Insert = Rs(0)
End Function
Public Function Execute(ByVal Sql)
OpenConn()
Set Execute = Conn.Execute(Sql)
End Function
Public Function ExecuteScalar(ByVal Sql)
Dim iRs : Set iRs = Execute(Sql)
If Not iRs.BOF Then ExecuteScalar = iRs(0)
End Function
Public Function ExecuteNonQuery(ByVal Sql)
OpenConn()
Call Conn.Execute(Sql, ExecuteNonQuery)
End Function
Public Function InsertSp(ByVal Sql, ByVal Params)
OpenConn()
Rs.Open Sql, Conn, 3, 3, adCmdStoredProc
Rs.AddNew
Dim i, l
l = UBound(Params)
For i = 1 To l + 1
Rs(i) = Params(i - 1)
Next
Rs.Update
InsertSp = Rs(0)
End Function
Public Function ExecuteSp(ByVal SpName, ByVal Params)
With Cmd
Set .ActiveConnection = OpenConn()
.CommandText = SpName
.CommandType = &H0004
.Prepared = True
Set ExecuteSp = .Execute(,Params)
End With
End Function
Public Function ExecuteDataTableSp(ByVal SpName, ByVal Params)
OpenConn()
If Rs.State <> adStateClose Then
Rs.Close()
End If
Dim SpStr
If IsNull(Params) Or IsEmpty(Params) Then
SpStr = SpName
Else
If IsArray(Params) Then
SpStr = "Execute " & SpName & " " & Join(Params, ",")
Else
SpStr = "Execute " & SpName & " " & Params
End If
End If
Call Rs.Open(SpStr, Conn, 1, 1, adCmdStoredProc)
Set ExecuteDataTableSp = Rs
End Function
Public Function ExecuteScalarSp(ByVal SpName, ByVal Params)
Dim iRs : Set iRs = ExecuteSp(SpName, Params)
If Not iRs.BOF Then ExecuteScalarSp = iRs(0)
End Function
Public Function ExecuteNonQuerySp(ByVal SpName, ByVal Params)
With Cmd
Set .ActiveConnection = OpenConn()
.CommandText = SpName
.CommandType = &H0004
.Prepared = True
Call .Execute(ExecuteNonQuerySp, Params)
End With
End Function
Private Sub Class_Initialize()
Set Conn = Server.CreateObject("ADODB.Connection")
Set Cmd = Server.CreateObject("ADODB.Command")
Set Param = Server.CreateObject("ADODB.Parameter")
Set Rs = Server.CreateObject("ADODB.RecordSet")
DataPath = "/data/data.mdb" ’这里写你的数据库默认路径，建议更改名称及扩展名
End Sub
Private Sub Class_Terminate()
Set Param = Nothing
Set Cmd = Nothing
CloseRs()
CloseConn()
End Sub
Private Sub CloseConn()
If Conn.State <> adStateClose Then
Conn.Close()
Set Conn = Nothing
End If
End Sub
Private Sub CloseRs()
If Rs.State <> adStateClose Then
Rs.Close()
Set Rs = Nothing
End If
End Sub
End Class
%>
}}}

2, 封装Cookie，Session，Application: 再把其它的操作，比如Cookie，Session，Application封装
{{{
CookieState类：

<%
Class CookieState
Private CurrentKey
Public Default Property Get Contents(ByVal Value)
Contents = Values(Value)
End Property
Public Property Let Expires(ByVal Value)
Response.Cookies(CurrentKey).Expires = DateAdd("d", Value, Now)
End Property
Public Property Get Expires()
Expires = Request.Cookies(CurrentKey).Expires
End Property
Public Property Let Path(ByVal Value)
Response.Cookies(CurrentKey).Path = Value
End Property
Public Property Get Path()
Path = Request.Cookies(CurrentKey).Path
End Property
Public Property Let Domain(ByVal Value)
Response.Cookies(CurrentKey).Domain = Value
End Property
Public Property Get Domain()
Domain = Request.Cookies(CurrentKey).Domain
End Property
Public Sub Add(ByVal Key, ByVal Value, ByVal Options)
Response.Cookies(Key) = Value
CurrentKey = Key
If Not (IsNull(Options) Or IsEmpty(Options) Or Options = "") Then
If IsArray(Options) Then
Dim l : l = UBound(Options)
Expire = Options(0)
If l = 1 Then Path = Options(1)
If l = 2 Then Domain = Options(2)
Else
Expire = Options
End If
End If
End Sub
Public Sub Remove(ByVal Key)
CurrentKey = Key
Expires = -1000
End Sub
Public Sub RemoveAll()
Clear()
End Sub
Public Sub Clear()
Dim iCookie
For Each iCookie In Request.Cookies
Response.Cookies(iCookie).Expires = FormatDateTime(Now)
Next
End Sub
Public Function Values(ByVal Key)
Values = Request.Cookies(Key)
End Function

Private Sub Class_initialize()
End Sub
Private Sub Class_Terminate()
End Sub
End Class
%>

SessionState类：
<%
Class SessionState
Public Default Property Get Contents(ByVal Key)
Contents = Session(Key)
End Property
Public Property Let TimeOut(ByVal Value)
Session.TimeOut = Value
End Property
Public Property Get TimeOut()
TimeOut = Session.TimeOut
End Property
Public Sub Add(ByVal Key, ByVal Value)
Session(Key) = Value
End Sub
Public Sub Remove(ByVal Key)
Session.Contents.Remove(Key)
End Sub
Public Function Values(ByVal Key)
Values = Session(Key)
End Function
Public Sub Clear()
Session.Abandon()
End Sub
Public Sub RemoveAll()
Clear()
End Sub

Private Sub Class_initialize()
End Sub
Private Sub Class_Terminate()
End Sub
End Class
%>
Application类封装成CacheState类：
<%
Class CacheState
Private IExpires
Public Default Property Get Contents(ByVal Value)
Contents = Values(Value)
End Property
Public Property Let Expires(ByVal Value)
IExpires = DateAdd("d", Value, Now)
End Property
Public Property Get Expires()
Expires = IExpires
End Property
Public Sub Lock()
Application.Lock()
End Sub
Public Sub UnLock()
Application.UnLock()
End Sub
Public Sub Add(ByVal Key, ByVal Value, ByVal Expire)
Expires = Expire
Lock
Application(Key) = Value
Application(Key & "Expires") = Expires
UnLock
End Sub
Public Sub Remove(ByVal Key)
Lock
Application.Contents.Remove(Key)
Application.Contents.Remove(Key & "Expires")
UnLock
End Sub
Public Sub RemoveAll()
Clear()
End Sub
Public Sub Clear()
Application.Contents.RemoveAll()
End Sub
Public Function Values(ByVal Key)
Dim Expire : Expire = Application(Key & "Expires")
If IsNull(Expire) Or IsEmpty(Expire) Then
Values = ""
Else
If IsDate(Expire) And CDate(Expire) > Now Then
Values = Application(Key)
Else
Call Remove(Key)
Value = ""
End If
End If
End Function
Public Function Compare(ByVal Key1, ByVal Key2)
Dim Cache1 : Cache1 = Values(Key1)
Dim Cache2 : Cache2 = Values(Key2)
If TypeName(Cache1) <> TypeName(Cache2) Then
Compare = True
Else
If TypeName(Cache1)="Object" Then
Compare = (Cache1 Is Cache2)
Else
If TypeName(Cache1) = "Variant()" Then
Compare = (Join(Cache1, "^") = Join(Cache2, "^"))
Else
Compare = (Cache1 = Cache2)
End If
End If
End If
End Function

Private Sub Class_initialize()
End Sub
Private Sub Class_Terminate()
End Sub
End Class
%>
}}}

上面3个类，在实例化时可以用去掉State后的类名，比如
Dim Cookie : Set Cookie = New CookieState
Dim Session : Set Session = New SessionState
Dim Cache : Set Cache = New CacheState

3, 封装其它工具类:其它的一些，比如分页类，异常类（用于信息提示），文件操作类（未完成），经常用到的工具类及验证输入的表单验证类（ASP版，配合前台JS版使用更佳）：
{{{
分页类Pager
<%
Class Pager
Private IUrl
Private IPage
Private IParam
Private IPageSize
Private IPageCount
Private IRecordCount
Private ICurrentPageIndex
Public Property Let Url(ByVal PUrl)
IUrl = PUrl
End Property
Public Property Get Url()
If IUrl = "" Then
If Request.QueryString <> "" Then
Dim query
For Each key In Request.QueryString
If key <> Param Then
query = query & key & "=" & Server.UrlEnCode(Request.QueryString(key)) & "&"
End If
Next
IUrl = Page & "?" & query & Param & "="
Else
IUrl = Page & "?" & Param & "="
End If
End If
Url =IUrl
End Property
Public Property Let Page(ByVal PPage)
IPage = PPage
End Property
Public Property Get Page()
Page = IPage
End Property
Public Property Let Param(ByVal PParam)
IParam = PParam
End Property
Public Property Get Param()
Param = IParam
End Property
Public Property Let PageSize(ByVal PPageSize)
IPageSize = PPageSize
End Property
Public Property Get PageSize()
PageSize = IPageSize
End Property
Public Property Get PageCount()
If (Not IPageCount > 0) Then
IPageCount = IRecordCount IPageSize
If (IRecordCount MOD IPageSize) > 0 Or IRecordCount = 0 Then
IPageCount = IPageCount + 1
End If
End If
PageCount = IPageCount
End Property
Public Property Let RecordCount(ByVal PRecordCount)
IRecordCount = PRecordCount
End Property
Public Property Get RecordCount()
RecordCount = IRecordCount
End Property
Public Property Let CurrentPageIndex(ByVal PCurrentPageIndex)
ICurrentPageIndex = PCurrentPageIndex
End Property
Public Property Get CurrentPageIndex()
If ICurrentPageIndex = "" Then
If Request.QueryString(Param) = "" Then
ICurrentPageIndex = 1
Else
If IsNumeric(Request.QueryString(Param)) Then
ICurrentPageIndex = CInt(Request.QueryString(Param))
If ICurrentPageIndex < 1 Then ICurrentPageIndex = 1
If ICurrentPageIndex > PageCount Then ICurrentPageIndex = PageCount
Else ICurrentPageIndex = 1
End If
End If
End If
CurrentPageIndex = ICurrentPageIndex
End Property
Private Sub Class_Initialize()
With Me
.Param = "page"
.PageSize = 10
End With
End Sub
Private Sub Class_Terminate()
End Sub
Private Function Navigation()
Dim Nav
If CurrentPageIndex = 1 Then
Nav = Nav & " 首页上页 "
Else
Nav = Nav & " <a href=""" & Url & "1"">首页</a> <a href=""" & Url & (CurrentPageIndex - 1) & """>上页</a> "
End If
If CurrentPageIndex = PageCount Or PageCount = 0 Then
Nav = Nav & " 下页尾页 "
Else
Nav = Nav & " <a href=""" & Url & (CurrentPageIndex + 1) & """>下页</a> <a href=""" & Url & PageCount & """>尾页</a> "
End If
Navigation = Nav
End Function
Private Function SelectMenu()
Dim Selector
Dim i : i = 1
While i <= PageCount
If i = ICurrentPageIndex Then
Selector = Selector & "<option value=""" & i & """ selected=""true"">" & i &"</option>" & vbCrLf
Else
Selector = Selector & "<option value=""" & i & """>" & i &"</option>" & vbCrLf
End If
i = i + 1
Wend
SelectMenu = vbCrLf & "<select style=""font:9px Tahoma"" onchange=""location=’" & Url & "’ + this.value"">" & vbCrLf & Selector & vbCrLf & "</select>" & vbCrLf
End Function
Public Sub Display()
If RecordCount > 0 Then
%>
<style>b{font:bold}</style>
<div style="text-align:right;width:100%">>>分页 <%=Navigation()%> 页次：<b><%=ICurrentPageIndex%></b>/<b><%= PageCount%></b>页 <b><%=PageSize%></b>个记录/页转到<%=SelectMenu()%>页共 <b><%=IRecordCount%></b>条记录</div>
<%
Else
Response.Write("<div style=""text-align:center"">暂无记录</div>")
End If
End Sub
End Class
%>
异常类Exception：
<%
Class Exception
Private IWindow
Private ITarget
Private ITimeOut
Private IMode
Private IMessage
Private IHasError
Private IRedirect
Public Property Let Window(ByVal Value)
IWindow = Value
End Property
Public Property Get Window()
Window = IWindow
End Property
Public Property Let Target(ByVal Value)
ITarget = Value
End Property
Public Property Get Target()
Target = ITarget
End Property
Public Property Let TimeOut(ByVal Value)
If IsNumeric(Value) Then
ITimeOut = CInt(Value)
Else
ITimeOut = 3000
End If
End Property
Public Property Get TimeOut()
TimeOut = ITimeOut
End Property
Public Property Let Mode(ByVal Value)
If IsNumeric(Value) Then
IMode = CInt(Mode)
Else
IMode = 1
End If
End Property
Public Property Get Mode()
Mode = IMode
End Property
Public Property Let Message(ByVal Value)
If IHasError Then
IMessage = IMessage & "<li>" & Value & "</li>" & vbCrLf
Else
IHasError = True
IMessage = "<li>" & Value & "</li>" & vbCrLf
End If
End Property
Public Property Get Message()
Message = IMessage
End Property
Public Property Let HasError(ByVal Value)
IHasError = CBool(Value)
End Property
Public Property Get HasError()
HasError = IHasError
End Property
Public Property Let Redirect(ByVal Value)
IRedirect = CBool(Value)
End Property
Public Property Get Redirect()
Redirect = IRedirect
End Property
Private Sub Class_initialize()
With Me
.Window = "self"
.Target = PrePage()
.TimeOut = 3000
IMode = 1
IMessage = "出现错误，正在返回，请稍候..."
.HasError = False
.Redirect = True
End With
End Sub

Private Sub Class_Terminate()
End Sub
Public Function PrePage()
If Request.ServerVariables("HTTP_REFERER") <> "" Then
PrePage = Request.ServerVariables("HTTP_REFERER")
Else
PrePage = "/index.asp"
End If
End Function
Public Function Alert()
Dim words : words = Me.Message
words = Replace(words, "<li>", " ")
words = Replace(words, "</li>", "")
words = Replace(words, vbCrLf, "")
words = "提示信息： " & words
%>
<script type="text/javascript">

</script>
<%
End Function
Public Sub Throw()
If Not HasError Then Exit Sub
Response.Clear()
Select Case CInt(Me.Mode)
Case 1
%>
<link href="/css/admin.css" rel="stylesheet" type="text/css">
<TABLE class="border-all" cellSpacing="1" cellPadding="5" width="50%" align="center" border="0">
<TBODY>
<TR>
<TH height="21" align="middle" background="images/th_bg.gif" class="title">提示信息</TH>
</TR>
<TR>
<TD align="center" bgColor="#ffffff" height="40">
<TABLE cellSpacing="0" cellPadding="0" width="95%" border="0">
<TBODY>
<TR>
<TD height="5"></TD>
</TR>
<TR>
<TD><%=Me.Message%></TD>
</TR>
<TR>
<TD> </TD>
</TR>
<TR>
<TD align="center"><a href="javascript :history.back()">[返回]</a> <a href="/">[首页]</a> </TD>
</TR>
</TBODY>
</TABLE>
</TD>
</TR>
</TBODY>
</TABLE>
<% If Redirect Then%> <script type="text/javascript">

</script><%end If%>
<%
Case 2
Call Alert()
Case Else
Response.Write Message
End Select
Response.End()
End Sub
End Class
%>
文件操作类File：
<%
Class File
Private FSO
Private IPath
Private IContent
Public Property Let Path(ByVal PPath)
IPath = PPath
End Property
Public Property Get Path()
Path = IPath
End Property
Public Property Let Content(ByVal PContent)
IContent = PContent
End Property
Public Property Get Content()
Content = IContent
End Property
Private Sub Class_Initialize()
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
End Sub
Private Sub Class_Terminate()
Set FSO = Nothing
End Sub
Public Sub Save()
Dim f
Set f = FSO.OpenTextFile(Server.MapPath(Path), 2, true)
f.Write Content
End Sub
End Class
%>

常用的工具类Utility：
<%
Class Utility
Private Reg
Public Function HTMLEncode(Str)
If IsNull(Str) Or IsEmpty(Str) Or Str = "" Then
HTMLEncode = ""
Else
Dim S : S = Str
S = Replace(S, "<", "<")
S = Replace(S, ">", ">")
S = Replace(S, " ", " ")
S = Replace(S, vbCrLf, "<br />")
HTMLEncode = S
End If
End Function
Public Function HtmlFilter(ByVal Code)
If IsNull(Code) Or IsEmpty(Code) Then Exit Function
With Reg
.Global = True
.Pattern = "<[^>]+?>"
End With
Code = Reg.Replace(Code, "")
HtmlFilter = Code
End Function
Public Function Limit(ByVal Str, ByVal Num)
Dim StrLen : StrLen = Len(Str)
If StrLen * 2 <= Num Then
Limit = Str
Else
Dim StrRlen
Call Rlen(Str, StrRlen)
If StrRlen <= Num Then
Limit = Str
Else
Dim i
Dim reStr
If StrLen > Num * 2 Then
i = Num 2
reStr = Left(Str, i)
Call Rlen(reStr, StrRlen)
While StrRlen < Num
i = i + 1
reStr = Left(Str, i)
Call Rlen(reStr, StrRlen)
Wend
Else
i = StrLen
reStr = Str
Call Rlen(reStr, StrRlen)
While StrRlen > Num
i = i - 1
reStr = Left(Str, i)
Call Rlen(reStr, StrRlen)
Wend
End If
Call Rlen(Right(reStr, 1), StrRlen)
If StrRlen > 1 Then
Limit = Left(reStr, i-1) & "…"
Else
Limit = Left(reStr, i-2) & "…"
End If
End If
End If
End Function
Public Function Encode(ByVal Str)
Str = Replace(Str, """", """)
Str = Replace(Str, "’", "'")
Encode = Str
End Function
Public Function EncodeAll(ByVal Str)
Dim M, MS
Reg.Pattern = "[x00-xFF]"
Set MS = Reg.Execute(Str)
For Each M In MS
Str = Replace(Str, M.Value, "&#" & Asc(M.Value) & ";")
Next
EncodeAll = Str
End Function

Private Sub Class_initialize()
Set Reg = New RegExp
Reg.Global = True
End Sub
Private Sub Class_Terminate()
Set Reg = Nothing
End Sub
Public Sub Rlen(ByRef Str, ByRef Rl)
With Reg
.Pattern = "[^x00-xFF]"
Rl = Len(.Replace(Str, ".."))
End With
End Sub
End Class
%>
<%
Dim Util : Set Util = New Utility
%>
输入验证类Validator：
<%@Language="VBScript" CodePage="936"%>
<%
’Option Explicit
Class Validator
’*************************************************
’ Validator for ASP beta 3 服务器端脚本
’ code by 我佛山人
’ wfsr@cunite.com
’*************************************************
Private Re
Private ICodeName
Private ICodeSessionName
Public Property Let CodeName(ByVal PCodeName)
ICodeName = PCodeName
End Property
Public Property Get CodeName()
CodeName = ICodeName
End Property
Public Property Let CodeSessionName(ByVal PCodeSessionName)
ICodeSessionName = PCodeSessionName
End Property
Public Property Get CodeSessionName()
CodeSessionName = ICodeSessionName
End Property
Private Sub Class_Initialize()
Set Re = New RegExp
Re.IgnoreCase = True
Re.Global = True
Me.CodeName = "vCode"
Me.CodeSessionName = "vCode"
End Sub
Private Sub Class_Terminate()
Set Re = Nothing
End Sub
Public Function IsEmail(ByVal Str)
IsEmail = Test("^w+([-+.]w+)*@w+([-.]w+)*.w+([-.]w+)*$", Str)
End Function
Public Function IsUrl(ByVal Str)
IsUrl = Test("^http://[A-Za-z0-9]+.[A-Za-z0-9]+[/=?%-&_~`@[]’:+!]*([^<>""])*$", Str)
End Function
Public Function IsNum(ByVal Str)
IsNum= Test("^d+$", Str)
End Function
Public Function IsQQ(ByVal Str)
IsQQ = Test("^[1-9]d{4,8}$", Str)
End Function
Public Function IsZip(ByVal Str)
IsZip = Test("^[1-9]d{5}$", Str)
End Function
Public Function IsIdCard(ByVal Str)
IsIdCard = Test("^d{15}(d{2}[A-Za-z0-9])?$", Str)
End Function
Public Function IsChinese(ByVal Str)
IsChinese = Test("^[u0391-uFFE5]+$", Str)
End Function
Public Function IsEnglish(ByVal Str)
IsEnglish = Test("^[A-Za-z]+$", Str)
End Function
Public Function IsMobile(ByVal Str)
IsMobile = Test("^(((d{3}))|(d{3}-))?13d{9}$", Str)
End Function
Public Function IsPhone(ByVal Str)
IsPhone = Test("^(((d{3}))|(d{3}-))?((0d{2,3})|0d{2,3}-)?[1-9]d{6,7}$", Str)
End Function
Public Function IsSafe(ByVal Str)
IsSafe = (Test("^(([A-Z]*|[a-z]*|d*|[-_~!@#$%^&*.()[]{}<>?/’""]*)|.{0,5})$|s", Str) = False)
End Function
Public Function IsNotEmpty(ByVal Str)
IsNotEmpty = LenB(Str) > 0
End Function
Public Function IsDateFormat(ByVal Str, ByVal Format)
IF Not IsDate(Str) Then
IsDateFormat = False
Exit Function
End IF
IF Format = "YMD" Then
IsDateFormat = Test("^((d{4})|(d{2}))([-./])(d{1,2})4(d{1,2})$", Str)
Else
IsDateFormat = Test("^(d{1,2})([-./])(d{1,2})2((d{4})|(d{2}))$", Str)
End IF
End Function
Public Function IsEqual(ByVal Src, ByVal Tar)
IsEqual = (Src = Tar)
End Function
Public Function Compare(ByVal Op1, ByVal Operator, ByVal Op2)
Compare = False
IF Dic.Exists(Operator) Then
Compare = Eval(Dic.Item(Operator))
Elseif IsNotEmpty(Op1) Then
Compare = Eval(Op1 & Operator & Op2 )
End IF
End Function
Public Function Range(ByVal Src, ByVal Min, ByVal Max)
Min = CInt(Min) : Max = CInt(Max)
Range = (Min < Src And Src < Max)
End Function
Public Function Group(ByVal Src, ByVal Min, ByVal Max)
Min = CInt(Min) : Max = CInt(Max)
Dim Num : Num = UBound(Split(Src, ",")) + 1
Group = Range(Num, Min - 1, Max + 1)
End Function
Public Function Custom(ByVal Str, ByVal Reg)
Custom = Test(Reg, Str)
End Function
Public Function Limit(ByVal Str, ByVal Min, ByVal Max)
Min = CInt(Min) : Max = CInt(Max)
Dim L : L = Len(Str)
Limit = (Min <= L And L <= Max)
End Function
Public Function LimitB(ByVal Str, ByVal Min, ByVal Max)
Min = CInt(Min) : Max = CInt(Max)
Dim L : L =bLen(Str)
LimitB = (Min <= L And L <= Max)
End Function
Private Function Test(ByVal Pattern, ByVal Str)
If IsNull(Str) Or IsEmpty(Str) Then
Test = False
Else
Re.Pattern = Pattern
Test = Re.Test(CStr(Str))
End If
End Function
Public Function bLen(ByVal Str)
bLen = Len(Replace(Str, "[^x00-xFF]", ".."))
End Function
Private Function Replace(ByVal Str, ByVal Pattern, ByVal ReStr)
Re.Pattern = Pattern
Replace = Re.Replace(Str, ReStr)
End Function
Private Function B2S(ByVal iStr)
Dim reVal : reVal= ""
Dim i, Code, nCode
For i = 1 to LenB(iStr)
Code = AscB(MidB(iStr, i, 1))
IF Code < &h80 Then
reVal = reVal & Chr(Code)
Else
nCode = AscB(MidB(iStr, i+1, 1))
reVal = reVal & Chr(CLng(Code) * &h100 + CInt(nCode))
i = i + 1
End IF
Next
B2S = reVal
End Function
Public Function SafeStr(ByVal Name)
If IsNull(Name) Or IsEmpty(Name) Then
SafeStr = False
Else
SafeStr = Replace(Trim(Name), "(s*ands*w*=w*)|[’%&<>=]", "")
End If
End Function
Public Function SafeNo(ByVal Name)
If IsNull(Name) Or IsEmpty(Name) Then
SafeNo = 0
Else
SafeNo = (Replace(Trim(Name), "^[D]*(d+)[Dd]*$", "$1"))
End If
End Function
Public Function IsValidCode()
IsValidCode = ((Request.Form(Me.CodeName) = Session(Me.CodeSessionName)) AND Session(Me.CodeSessionName) <> "")
End Function
Public Function IsValidPost()
Dim Url1 : Url1 = Cstr(Request.ServerVariables("HTTP_REFERER"))
Dim Url2 : Url2 = Cstr(Request.ServerVariables("SERVER_NAME"))
IsValidPost = (Mid(Url1, 8, Len(Url2)) = Url2)
End Function
End Class
%>

还有一个读取XML的类 XmlReader：
<%
Class XmlReader
Private Xml
Public Sub Load(ByVal Path)
Xml.Load(Server.MapPath(Path))
End Sub
Public Function SelectSingleNode(ByVal XPath)
Set SelectSingleNode = Xml.SelectSingleNode(XPath)
End Function
Public Function SelectNodes(ByVal XPath)
Set SelectNodes = Xml.SelectNodes(XPath)
End Function

Private Sub Class_initialize()
Set Xml = Server.CreateObject("Microsoft.XMLDOM")
Xml.async = False
’Xml.setProperty "ServerHTTPRequest", True
End Sub
Private Sub Class_Terminate()
Set Xml = Nothing
End Sub
End Class
%>
}}}

== 二，三层结构的实现 ==
好了，万事俱备，开始搭建基本的三层：
数据模型层：此层对应成一个类，类的类名和字段属性对应于数据库的相应表名及字段。
考虑表News，其结构如下：

则其对应的模型层如下：
<%
Class DataNews
Private IAddDate
Private IContent
Private ICount
Private INewsID
Private ITitle
Private IUserID
Private IUserName
Public Property Let AddDate(ByVal Value)
IAddDate = Value
End Property
Public Property Get AddDate()
AddDate = IAddDate
End Property
Public Property Let Content(ByVal Value)
IContent = Value
End Property
Public Property Get Content()
Content = IContent
End Property
Public Property Let Count(ByVal Value)
ICount = Value
End Property
Public Property Get Count()
Count = ICount
End Property
Public Property Let NewsID(ByVal Value)
INewsID = Value
End Property
Public Property Get NewsID()
NewsID = INewsID
End Property
Public Property Let Title(ByVal Value)
ITitle = Value
End Property
Public Property Get Title()
Title = ITitle
End Property
Public Property Let UserID(ByVal Value)
IUserID = Value
End Property
Public Property Get UserID()
UserID = IUserID
End Property
Public Property Let UserName(ByVal Value)
IUserName = Value
End Property
Public Property Get UserName()
UserName = IUserName
End Property
Private Sub Class_initialize()
End Sub
Private Sub Class_Terminate()
End Sub
End Class
%>

这里用了类名DataNews，因为VBScript不支持Namespace(-_ -)，以前缀区分，而类中私有属性用I作前缀，没什么特别含义，仅仅是因为I所占宽度较小，不影响理解时的联想反应速度，如果非要拉点合理的解释的话，那么就是，Private中的I，以区分于Public，不用m_之类，是因为觉得它不够美观，影响编码心情（所以不喜欢写C），因为需要以优雅之心情，编写优雅的代码(哎呀，谁扔的鸡蛋？拜托换个新鲜点的）。

继续我们的数据访问层：

<%
Class DalNews
Private news
Private db
Public Property Let NewsID(ByVal Value)
news.NewsID = Value
End Property
Public Property Get NewsID()
NewsID = news.NewsID
End Property
Public Property Let UserID(ByVal Value)
news.UserID = Value
End Property
Public Property Get UserID()
UserID = news.UserID
End Property
Public Property Let Title(ByVal Value)
news.Title = Value
End Property
Public Property Get Title()
Title = news.Title
End Property
Public Property Let Content(ByVal Value)
news.Content = Value
End Property
Public Property Get Content()
Content = news.Content
End Property
Public Property Let Count(ByVal Value)
news.Count = Value
End Property
Public Property Get Count()
Count = news.Count
End Property
Public Property Let AddDate(ByVal Value)
news.AddDate = Value
End Property
Public Property Get AddDate()
AddDate = news.AddDate
End Property
Public Property Let UserName(ByVal Value)
news.UserName = Value
End Property
Public Property Get UserName()
UserName = news.UserName
End Property
Public Function SelectOne()
Dim rs : Set rs = db.ExecuteSp("News_SelectOne", Me.NewsID)
If Not (rs.BOF OR rs.EOF) Then
With Me
.NewsID = rs(0)
.UserID = rs(1)
.Title = rs(2)
Dim tmpContent : tmpContent = rs(3)
.Content = tmpContent
.Count = rs(4)
.AddDate = rs(5)
.UserName = rs(6)
End With
SelectOne = True
Else
SelectOne = False
End If
End Function
Public Function SelectTop()
Dim rs : Set rs = db.ExecuteSp("News_SelectTop", Null)
If Not (rs.BOF OR rs.EOF) Then
With Me
.NewsID = rs(0)
.UserID = rs(1)
.Title = rs(2)
Dim tmpContent : tmpContent = rs(3)
.Content = tmpContent
.Count = rs(4)
.AddDate = rs(5)
.UserName = rs(6)
End With
End If
Set SelectTop = rs
End Function
Public Function SelectAll()
Set SelectAll = db.ExecuteDataTableSp("News_SelectAll", Null)
End Function
Public Function Insert()
Me.NewsID = db.InsertSp("News_Insert", Array(Me.UserID, Me.Title, Me.Content, Me.Count))
Insert = Me.NewsID
End Function
Public Function Update()
Update = db.ExecuteNonQuerySp("News_Update", Array(Me.Title, Me.Content, Me.Count, Me.NewsID)) > 0
End Function
Public Function UpdateCount()
UpdateCount = db.ExecuteNonQuerySp("News_UpdateCount", Me.NewsID) > 0
End Function
Public Function Delete()
Delete = db.ExecuteNonQuerySp("News_Delete", Me.NewsID) > 0
End Function
Public Function BatchDelete(ByVal NewsIDs)
BatchDelete = db.ExecuteNonQuery("DELETE * FROM News WHERE NewsID IN (" & NewsIDs & ")")
End Function
Private Sub Class_initialize()
Set news = New DataNews
Set db = New Oledb
End Sub
Private Sub Class_Terminate()
Set news = Nothing
Set db = Nothing
End Sub
End Class
%>

第一行是导入之前的模型层，可以看到虽然模型层类名为DataNews，但文件名为News.asp，我们把所有类名都是表名相关，文件名与表名一样，分别存于不同文件夹。这个数据访问层的类名为DalNews，类里实例化刚才的模型层，实例名是表名的小写。
这一层里我们还实例化了Oledb，类名就用db，可以看到，类里只看到一句批量删除时的SQL语句(因为ACCESS查询不支持，也有可能是我测试不成功，方法不对)，其它的只是一个名称，有点象MSSQL里的存储过程，其实这是ACCESS里的查询，轻量级的存储过程，仅仅支持简单的SQL语句，参数以中括号及书写顺序标识。

下来是逻辑层，这个层比较重要，因为主要判断都在这里，把数据访问层包含进来，类名为 BllNews.asp，放于/Bll/文件夹下，刚才的数据访问层放于/Dal/文件夹下，数据模型层放于/Data/文件夹下，所有文件名都是 News.asp。商业逻辑层的类需要实例化Validator和Exception，实例化的Cookie类主要用于限制点击数的增加。可以根据需要去留。这里还对每个属性接受的数据进行判断，判断依据主要是根据数据库的字段属性限制，比如字段类型，字段长度等，对于数字的验证，用Validator中的SafeNo，使本应用可以免受SQL Injection之扰。

<%
Class BllNews
Private v
Private e
Private news
Private Cookie
Public Property Let NewsID(ByVal Value)
If Not IsEmpty(Value) And v.IsNum(v.SafeNo(Value)) Then
news.NewsID = CInt(v.SafeNo(Value))
Else
news.NewsID = 0
e.Message = "NewsID参数错误"
End If
End Property
Public Property Get NewsID()
NewsID = news.NewsID
End Property
Public Property Let UserID(ByVal Value)
If Not IsEmpty(Value) And v.IsNum(v.SafeNo(Value)) Then
news.UserID = CInt(v.SafeNo(Value))
Else
news.UserID = 0
e.Message = "UserID参数错误"
End If
End Property
Public Property Get UserID()
UserID = news.UserID
End Property
Public Property Let Title(ByVal Value)
If v.Limit(Value, 1, 100) Then
news.Title = Value
Else
If IsNull(Value) or IsEmpty(Value) Or Value = "" Then
news.Title = ""
e.Message = "新闻标题不允许为空"
Else
news.Title = Left(Value, 100)
e.Message = "新闻标题字符长度超过100"
End If
End If
End Property
Public Property Get Title()
Title = news.Title
End Property
Public Property Let Content(ByVal Value)
If IsNull(Value) or IsEmpty(Value) Or Value = "" Then
news.Content = ""
e.Message = "新闻内容不允许为空"
Else
news.Content = Value
End If
End Property
Public Property Get Content()
Content = news.Content
End Property
Public Property Let Count(ByVal Value)
If Not IsEmpty(Value) And v.IsNum(v.SafeNo(Value)) Then
news.Count = CInt(v.SafeNo(Value))
Else
news.Count = 0
e.Message = "新闻点击数设置错误"
End If
End Property
Public Property Get Count()
Count = news.Count
End Property
Public Property Let AddDate(ByVal Value)
news.AddDate = Value
End Property
Public Property Get AddDate()
AddDate = FormatDateTime(CDate(news.AddDate), 1)
End Property
Public Property Let UserName(ByVal Value)
news.UserName = Value
End Property
Public Property Get UserName()
UserName = news.UserName
End Property
Public Sub Throw()
e.Throw()
End Sub
Public Function SelectOne()
NewsID = NewsID
If Not IsEmpty(NewsID) Then
SelectOne = news.SelectOne()
If SelectOne = False Then
e.Message = "参数错误，该新闻不存在或已被删除"
End If
End If
e.Throw()
End Function
Public Function SelectTop()
Set SelectTop = news.SelectTop()
End Function
Public Function SelectAll()
Set SelectAll = news.SelectAll()
End Function
Public Sub Insert()
UserID = UserID
Title = Title
Content = Content
Count = Count
e.Target = "/admin/News.asp"
e.Throw()
news.Insert()
If Me.NewsID > 0 Then
e.Message = "新闻添加成功，正在转到列表"
e.Target = "/admin/NewsList.asp"
Else
e.Message = "新闻添加失败，请检查输入"
End If
e.Throw()
End Sub
Public Sub Update()
e.Target = "/admin/NewsList.asp"
If news.Update() Then
e.Message = "新闻更新成功,正在返回..."
Else
e.Message = "新闻更新失败，请确认参数是否正确或新闻是否存在"
End If
e.Throw()
End Sub
Public Sub UpdateCount()
If Cookie("News" & Me.NewsID) = "" Then
news.UpdateCount()
Call Cookie.Add("News" & Me.NewsID, 1, 1)
End If
End Sub
Public Sub Delete()
e.Target = "/admin/NewsList.asp"
If news.Delete() Then
e.Message = "新闻删除成功,正在返回..."
Else
e.Message = "新闻删除失败，请确认参数是否正确或新闻是否存在"
End If
e.Throw()
End Sub
Public Sub BatchDelete(ByVal NewsIDs)
e.Target = "/admin/NewsList.asp"
Dim Rows : Rows = news.BatchDelete(NewsIDs)
If Rows > 0 Then
e.Message = "成功删除新闻<font color=’red’> " & Rows & " </font>条,正在返回..."
Else
e.Message = "新闻删除失败，请确认参数是否正确或新闻是否存在" & NewsIDs
End If
e.Throw()
End Sub
Private Sub Class_initialize()
Set v = New Validator
Set e = New Exception
Set news = New DalNews
Set Cookie = New CookieState
End Sub
Private Sub Class_Terminate()
Set v = Nothing
Set e = Nothing
Set news = Nothing
Set Cookie = Nothing
End Sub
End Class
%>

最终的表现层：


<%
Dim news : Set news = New BllNews
Dim navString : navString = " » <a href=""/news.asp"">XX动态</a>"
%>
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<title>XX有限公司</title>
<link href="css/news.css" rel="stylesheet" type="text/css">
</head>
<body>

<table width="760" border="0" align="center" cellpadding="0" cellspacing="0" bgcolor="#FFFFFF">
<tr>
<td width="220" align="center" valign="top">

</td>
<td width="540" align="center" valign="top" class="border"><table width="540" border="0" cellspacing="0" cellpadding="0">
<tr>
<td height="28" background="images/bar_mid_3.jpg" class="right_title">旅游新闻</td>
</tr>
<tr>
<td><table width=96% border=0 align=center cellpadding=2 cellspacing=0>
<tr>
<td height="5"> </td>
</tr>
<%
Dim rs : Set rs = news.SelectAll()
Dim p : Set p = New Pager
p.PageSize = 20
p.RecordCount = rs.RecordCount
Dim iIndex : iIndex = 0

If Not (rs.BOF or rs.EOF) Then
rs.Move((p.CurrentPageIndex - 1) * p.PageSize)
While Not rs.EOF And iIndex < p.PageSize
%>
<tr>
<td width=12><img src="images/dot_01.gif" width="12" height="9"></td>
<td><a href="NewsDetail.asp?ID=<%=rs("NewsID")%>" target="_blank" title="<%=Util.Encode(rs("Title"))%>"><%=Util.Limit(rs("Title"), 80)%>  [<%=rs("AddDate")%>]</a></td>
</tr>
<tr>
<td height=1 colspan=2 background="images/line_03.gif"></td>
</tr>
<%
iIndex = iIndex + 1
rs.MoveNext()
Wend
End If
Set rs = Nothing
%>
</table>
<table width="540" border="0" cellpadding="0" cellspacing="0">
<tr>
<td width="40%" height="30" align="center"><%=p.Display()%></td>
</tr>
</table></td>
</tr>
</table>
</td>
</tr>
<tr>
<td colspan="2" align="center"> </td>
</tr>
</table>

</body>
</html>
<%
Set news = Nothing
%>

第一行导入的Package.asp，是把需要导入的文件单独写到一个文件里，它的代码如下：








第二行导入的就是最后的商业逻辑层类。分页用了之前给的分页类Pager，可以看到，这里少了很多平时分页用到的if else等等的判断处理，这些都交由Pager类，而参数合法性则由逻辑层处理，表现层只负责数据的显示表现。

可以看到，这三层的代码编写，跟数据库的设计有很大关系，而且有规律，所以我尝试写了一个代码生成器。
1.第一次编写，只能生成模型类
<style>
* {font:12px Tahoma}
table{width:760px}
</style>
<%
Class Generator
Private IDataPath
Private IConnectionString
Private IDataDir
Private FSO
Private File
Private Conn
Private Rs
Public Property Let DataPath(ByVal Value)
IDataPath = Value
IConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(IDataPath)
End Property
Public Property Get DataPath()
DataPath = IDataPath
End Property
Public Property Let ConnectionString(ByVal Value)
IConnectionString = Value
End Property
Public Property Get ConnectionString()
ConnectionString = IConnectionString
End Property
Public Property Let DataDir(ByVal Value)
IDataDir = Value
End Property
Public Property Get DataDir()
DataDir = IDataDir
End Property
Public Sub Generate()
Dim Tables, i, L
Tables = ReadTable()
L = UBound(Tables)
For i=0 To L
Call Process(Tables(i), ReadColumn(Tables(i)))
Next
End Sub
Public Sub GenerateByTable(ByVal Table)
Call Process(Table, ReadColumn(Table))
End Sub
Private Sub Class_initialize()
Set Conn = Server.CreateObject("ADODB.Connection")
Set Rs = Server.CreateObject("ADODB.RecordSet")
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
DataDir = "Data/"
End Sub
Private Sub Class_Terminate()
CloseConn()
CloseRs()
Set FSO = Nothing
Set File = Nothing
End Sub
Private Sub Process(ByVal Table, ByVal Columns)
Dim i
Dim L : L = UBound(Columns)
Dim TmpString : TmpString = "<%" & vbCrLf & "Class Data" & Table & vbCrLf & vbCrLf
Dim Def, Pro
For i=0 To L
Def = Def & vbTab & "Private I" & Columns(i) & vbCrLf
Pro = Pro&vbCrLf&vbTab & "Public Property Let " & Columns(i) & "(ByVal Value)" & vbCrLf & vbTab &_
vbTab & "I" & Columns(i) & " = Value" &_
vbCrlf & vbTab & "End Property" &_
vbCrlf & vbTab & "Public Property Get " & Columns(i) & "()" &_
vbCrLf & vbTab & vbTab & Columns(i) & " = I" & Columns(i) &_
vbCrlf & vbTab & "End Property" & vbCrlf
Next
TmpString = TmpString & Def & Pro &_
vbCrlf & vbTab & "Private Sub Class_initialize()" &_
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbTab & "Private Sub Class_Terminate()" &_
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbCrLf& "End Class" & vbCrLf & "%" & Chr(62)
Call Save(Table, TmpString)
End Sub
Private Sub Save(ByVal Table, ByRef Content)
DetectDir(DataDir)
Dim Path : Path = Server.MapPath(DataDir & Table & ".asp")
Set File = FSO.OpenTextFile(Path, 2, true)
File.Write Content
Response.Write("<li>" & Path & "</li>")
End Sub
Private Sub DetectDir(DirName)
Dim Path : Path = Server.MapPath(DirName)
If Not FSO.FolderExists(Path) Then
FSO.CreateFolder(Path)
End If
End Sub
Private Sub OpenConn()
If Conn.State = adStateClosed Then
Conn.Open ConnectionString
End If
End Sub
Private Sub CloseConn()
If Conn.State = adStateOpen Then
Conn.Close()
Set Conn = Nothing
End If
End Sub
Private Sub CloseRs()
If Rs.State = adStateOpen Then
Rs.Close()
Set Rs = Nothing
End If
End Sub
Private Function ReadTable()
Dim TmpTable
OpenConn()
Set Rs = Conn.openSchema(20, Array(Empty, Empty, Empty,"TABLE"))
Rs.MoveFirst()
Do While Not Rs.EOF
TmpTable = TmpTable & "," & Rs("TABLE_NAME")
Rs.MoveNext()
Loop
ReadTable = Split(Mid(TmpTable, 2), ",")
End Function
Private Function ReadColumn(ByVal TableName)
Dim TmpColumn
OpenConn()
Set Rs = Conn.openSchema(4, Array(Empty, Empty, TableName, Empty))
Rs.MoveFirst()
Do While Not Rs.EOF
TmpColumn = TmpColumn & "," & Rs("COLUMN_NAME")
Rs.MoveNext()
Loop
ReadColumn = Split(Mid(TmpColumn, 2), ",")
End Function
End Class
Dim g : Set g = New Generator
g.DataPath = "/data/data.mdb"
g.Generate()
Set g = Nothing
%>

第二次编写，可以生成模型类和数据访问类，在数据访问类上的备注字段和主键的判断还需要推敲确定，现在是我根据Connection.openSchema方法遍历出的字段属性比较判断出来的。如果时间和技术允许，我希望能把另外的事件处理类，前台表现类（包括表单生成，数据列表页，详细显示页）一并生成，这将大大减轻程序员的编码时间和难度，前提是这个框架设计是健壮，安全且合理的，这就需要大家来一起测试改进。目前用VC做个界面的计划也在进行中
<style>
* {font:12px Tahoma}
table{width:760px}
</style>
<%
’On Error Resume Next
Class Generator
Private IDataPath
Private IConnectionString
Private IDataDir
Private IDalDir
Private IBllDir
Private IEventDir
Private FSO
Private File
Private Conn
Private cmd
Private Rs
Private Cat
Public Property Let DataPath(ByVal Value)
IDataPath = Value
IConnectionString = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(IDataPath)
End Property
Public Property Get DataPath()
DataPath = IDataPath
End Property
Public Property Let ConnectionString(ByVal Value)
IConnectionString = Value
End Property
Public Property Get ConnectionString()
ConnectionString = IConnectionString
End Property
Public Property Let DataDir(ByVal Value)
DetectDir(Value)
IDataDir = Value
End Property
Public Property Get DataDir()
DataDir = IDataDir
End Property
Public Property Let DalDir(ByVal Value)
DetectDir(Value)
IDalDir = Value
End Property
Public Property Get DalDir()
DalDir = IDalDir
End Property
Public Property Let BllDir(ByVal Value)
DetectDir(Value)
IBllDir = Value
End Property
Public Property Get BllDir()
BllDir = IBllDir
End Property
Public Property Let EventDir(ByVal Value)
DetectDir(Value)
IEventDir = Value
End Property
Public Property Get EventDir()
EventDir = IEventDir
End Property
Public Sub Generate()
Dim Tables, i, L
Tables = ReadTable()
L = UBound(Tables)
For i=0 To L
Call Process(Tables(i))
Next
End Sub
Public Sub GenerateByTable(ByVal Table)
Call Process(Table)
End Sub
Private Sub Class_Initialize()
Set Conn = Server.CreateObject("ADODB.Connection")
Set Rs = Server.CreateObject("ADODB.RecordSet")
Set FSO = Server.CreateObject("Scripting.FileSystemObject")
Set Cat = Server.CreateObject("ADOX.Catalog")
Set Cmd = Server.CreateObject("ADODB.Command")
DataDir = "DataClass/"
DalDir = "DalClass/"
BllDir = "BllClass/"
EventDir = "Action/"
End Sub
Private Sub Class_Terminate()
CloseConn()
CloseRs()
Set Cat = Nothing
Set Cmd = Nothing
Set FSO = Nothing
Set File = Nothing
End Sub
Private Sub Process(ByVal Table)
Set Rs = ReadColumn(Table)
’Call ProcessData(Rs)
’Call ProcessDal(Rs)
Call ProcessBll(Rs)
’Call ProcessEvent(Rs)
End Sub
Private Sub ProcessData(ByRef Rs)
Rs.Filter = "ORDINAL_POSITION=1"
If Rs.EOF Then Exit Sub
Dim n : n = 0
Dim Table : Table = Rs("TABLE_NAME")
Dim TmpString : TmpString = "<%" & vbCrLf & "Class Data" & Table & vbCrLf & vbCrLf
Dim Def, Pro
Do
n = n + 1
Rs.Filter = "ORDINAL_POSITION=" & n
If Rs.EOF Then Exit Do
Def = Def & vbTab & "Private I" & Rs("COLUMN_NAME") & vbCrLf
Pro = Pro & vbCrLf & vbTab & "’" & Rs("COLUMN_NAME") & vbCrLf &_
vbTab & "Public Property Let " & Rs("COLUMN_NAME") & "(ByVal Value)" & vbCrLf & vbTab &_
vbTab & "I" & Rs("COLUMN_NAME") & " = Value" &_
vbCrlf & vbTab & "End Property" &_
vbCrlf & vbTab & "Public Property Get " & Rs("COLUMN_NAME") & "()" &_
vbCrLf & vbTab & vbTab & Rs("COLUMN_NAME") & " = I" & Rs("COLUMN_NAME") &_
vbCrlf & vbTab & "End Property" & vbCrlf
Loop
TmpString = TmpString & Def & Pro &_
vbCrlf & vbTab & "Private Sub Class_Initialize()" &_
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbTab & "Private Sub Class_Terminate()" &_
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbCrLf& "End Class" & vbCrLf & "%" & Chr(62)
Call SaveDataClass(Table, TmpString)
End Sub
Private Sub ProcessDal(ByRef Rs)
Rs.Filter = "ORDINAL_POSITION=1"
If Rs.EOF Then Exit Sub
Dim n : n = 0
Dim Table : Table = Rs("TABLE_NAME")
Dim LTable : LTable = LCase(Table)
Dim TmpString : TmpString = "" & vbCrLf & "<%" & vbCrLf & "Class Dal" & Table & vbCrLf & vbCrLf & vbTab & "Private db" & vbCrLf & vbTab & "Private " & LTable & vbCrLf
Dim Def, Pro
Dim PK, Columns, ColumnName, LongTextField, soSql
Do
n = n + 1
Rs.Filter = "ORDINAL_POSITION=" & n
If Rs.EOF Then Exit Do
ColumnName = Rs("COLUMN_NAME")
If CInt(Rs("COLUMN_FLAGS")) = 90 AND CInt(Rs("DATA_TYPE")) = 3 Then PK = ColumnName
If CInt(Rs("COLUMN_FLAGS")) = 234 AND CInt(Rs("DATA_TYPE")) = 130 AND Rs("CHARACTER_OCTET_LENGTH") = "0" Then LongTextField = LongTextField & "," & ColumnName
Columns = Columns & "," & ColumnName
If n = 1 Then
soSql = vbTab & vbTab & " ." & ColumnName & " = rs(""" & ColumnName & """)" & vbCrLf
Else
soSql = soSql & vbTab & vbTab & " ." & ColumnName & " = rs(""" & ColumnName & """)" & vbCrLf
End If
Pro = Pro & vbCrLf & vbTab & "’" & ColumnName & vbCrLf &_
vbTab & "Public Property Let " & ColumnName & "(ByVal Value)" & vbCrLf & vbTab &_
vbTab & LTable & "." & ColumnName & " = Value" &_
vbCrlf & vbTab & "End Property" &_
vbCrlf & vbTab & "Public Property Get " & ColumnName & "()" &_
vbCrLf & vbTab & vbTab & ColumnName & " = " & LTable & "." & ColumnName &_
vbCrlf & vbTab & "End Property" & vbCrlf
Loop
Columns = Replace(Columns, "," & PK & ",", "")
If LongTextField <> "" Then
LongTextField = Mid(LongTextField, 2)
Dim arr : arr = Split(LongTextField, ",")
Dim arrLen : arrLen = UBound(arr)
Dim arrI
For arrI=0 To arrLen
soSql = Replace(soSql, "." & arr(arrLen) & " = rs(""" & arr(arrLen) & """)", "Dim tmp" & arr(arrLen) & " : tmp" & arr(arrLen) & " = rs(""" & arr(arrLen) & """)" & vbCrLf & " ." & arr(arrLen) & " = tmp" & arr(arrLen))
Next
End If
Dim SelectOneSp, SelectTopSp, SelectAllSp, InsertSp, UpdateSp, DeleteSp, BatchDeleteSp
SelectOneSp = vbTab &"Public Function SelectOne()" & vbCrLf &_
vbTab & vbTab & "Dim rs : Set rs = db.ExecuteSp(""" & Table & "_SelectOne"", " & PK & ")" & vbCrLf &_
vbTab & vbTab & "If Not (rs.BOF OR rs.EOF) Then" & vbCrLf &_
vbTab & vbTab & " With Me" & vbCrLf &_
soSql & _
vbTab & vbTab & " End With" & vbCrLf &_
vbTab & vbTab & " SelectOne = True" & vbCrLf &_
vbTab & vbTab & "Else" & vbCrLf &_
vbTab & vbTab & " SelectOne = False" & vbCrLf &_
vbTab & vbTab & "End If" & vbCrLf &_
vbTab &"End Function"
SelectTopSp = vbTab &"Public Function SelectTop()" & vbCrLf &_
vbTab & vbTab & "Set SelectTop = db.ExecuteDataTableSp(""" & Table & "_SelectTop"", Null)" & vbCrLf &_
vbTab &"End Function"
SelectAllSp = vbTab &"Public Function SelectAll()" & vbCrLf &_
vbTab & vbTab & "Set SelectAll = db.ExecuteDataTableSp(""" & Table & "_SelectAll"", Null)" & vbCrLf &_
vbTab & "End Function"
InsertSp = vbTab &"Public Function Insert()" & vbCrLf &_
vbTab & vbTab & PK & " = db.InsertSp(""" & Table & "_Insert"", Array(" & Join(Split(Columns, ","), ", ") & "))" & vbCrLf &_
vbTab & vbTab &"Insert = " & PK & vbCrLf &_
vbTab &"End Function"
UpdateSp = vbTab &"Public Function Update()" & vbCrLf &_
vbTab & vbTab & "Update = db.ExecuteNonQuerySp(""" & Table & "_Update"", Array(" & Join(Split(Columns, ","), ", ") & ", " & PK & ")) > 0" & vbCrLf &_
vbTab &"End Function"
DeleteSp = vbTab &"Public Function Delete()" & vbCrLf &_
vbTab & vbTab & "Delete = db.ExecuteNonQuerySp(""" & Table & "_Delete"", " & PK & ") > 0" & vbCrLf &_
vbTab &"End Function"
BatchDeleteSp = vbTab &"Public Function BatchDelete(ByVal " & PK & "s)" & vbCrLf &_
vbTab & vbTab & "BatchDelete = db.ExecuteNonQuery(""DELETE * FROM [" & Table & "] WHERE " & PK & " IN ("" & " & PK & "s & "")"")" & vbCrLf &_
vbTab &"End Function"
TmpString = TmpString & Pro &_
vbCrlf & SelectOneSp & vbCrLf &_
vbCrlf & SelectTopSp & vbCrLf &_
vbCrlf & SelectAllSp & vbCrLf &_
vbCrlf & InsertSp & vbCrLf &_
vbCrlf & UpdateSp & vbCrLf &_
vbCrlf & DeleteSp & vbCrLf &_
vbCrlf & BatchDeleteSp & vbCrLf &_
vbCrlf & vbTab & "Private Sub Class_Initialize()" &_
vbCrlf & vbTab & vbTab & "Set db = New Oledb" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = New Data" & Table & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbTab & "Private Sub Class_Terminate()" &_
vbCrlf & vbTab & vbTab & "Set db = Nothing" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = Nothing" & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbCrLf& "End Class" & vbCrLf & "%" & Chr(62)
Call SaveDalClass(Table, TmpString)
Call CreateSp(Table, PK, Columns)
’Response.Write "<div>" & PK & ":" & Columns & ":" & LongTextField & "</div>"
End Sub
Private Sub ProcessBll(ByRef Rs)
Rs.Filter = "ORDINAL_POSITION=1"
If Rs.EOF Then Exit Sub
Dim n : n = 0
Dim Table : Table = Rs("TABLE_NAME")
Dim LTable : LTable = LCase(Table)
Dim TmpString : TmpString = "" & vbCrLf & "<%" & vbCrLf & "Class Bll" & Table & vbCrLf & vbCrLf & vbTab & "Private v" & vbCrLf & vbTab & "Private e" & vbCrLf & vbTab & "Private " & LTable & vbCrLf
Dim Def, Pro
Dim PK
Do
n = n + 1
Rs.Filter = "ORDINAL_POSITION=" & n
If Rs.EOF Then Exit Do
If CInt(Rs("COLUMN_FLAGS")) = 90 Then PK = Rs("COLUMN_NAME")
Pro = Pro & vbCrLf & vbTab & "’" & Rs("COLUMN_NAME") & vbCrLf &_
vbTab & "Public Property Let " & Rs("COLUMN_NAME") & "(ByVal Value)" & vbCrLf & vbTab &_
vbTab & LTable & "." & Rs("COLUMN_NAME") & " = Value" &_
vbCrlf & vbTab & "End Property" &_
vbCrlf & vbTab & "Public Property Get " & Rs("COLUMN_NAME") & "()" &_
vbCrLf & vbTab & vbTab & Rs("COLUMN_NAME") & " = " & LTable & "." & Rs("COLUMN_NAME") &_
vbCrlf & vbTab & "End Property" & vbCrlf
Loop
TmpString = TmpString & Pro &_
vbCrlf & vbTab & "Public Sub Throw()" &_
vbCrlf & vbTab & " e.Throw()" &_
vbCrlf & vbTab & "End Sub" & vbCrlf &_
vbCrlf & vbTab & "Private Sub Class_Initialize()" &_
vbCrlf & vbTab & vbTab & "Set v = New Validator" & _
vbCrlf & vbTab & vbTab & "Set e = New Exception" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = New Data" & Table & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbTab & "Private Sub Class_Terminate()" &_
vbCrlf & vbTab & vbTab & "Set v = Nothing" & _
vbCrlf & vbTab & vbTab & "Set e = Nothing" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = Nothing" & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbCrLf& "End Class" & vbCrLf & "%" & Chr(62)
Call SaveBllClass(Table, TmpString)
End Sub
Private Sub ProcessEvent(ByRef Rs)
Rs.Filter = "ORDINAL_POSITION=1"
If Rs.EOF Then Exit Sub
Dim n : n = 0
Dim Table : Table = Rs("TABLE_NAME")
Dim LTable : LTable = LCase(Table)
Dim TmpString : TmpString = "" & vbCrLf & "" & vbCrLf & "<%" & vbCrLf & "Class Data" & Table & vbCrLf & vbCrLf & vbTab & "Private db" & vbCrLf & vbTab & "Private " & LTable & vbCrLf
Dim Def, Pro
Dim PK
Do
n = n + 1
Rs.Filter = "ORDINAL_POSITION=" & n
If Rs.EOF Then Exit Do
If CInt(Rs("COLUMN_FLAGS")) = 90 Then PK = Rs("COLUMN_NAME")
Pro = Pro & vbCrLf & vbTab & "’" & Rs("COLUMN_NAME") & vbCrLf &_
vbTab & "Public Property Let " & Rs("COLUMN_NAME") & "(ByVal Value)" & vbCrLf & vbTab &_
vbTab & LTable & "." & Rs("COLUMN_NAME") & " = Value" &_
vbCrlf & vbTab & "End Property" &_
vbCrlf & vbTab & "Public Property Get " & Rs("COLUMN_NAME") & "()" &_
vbCrLf & vbTab & vbTab & Rs("COLUMN_NAME") & " = " & LTable & "." & Rs("COLUMN_NAME") &_
vbCrlf & vbTab & "End Property" & vbCrlf
Loop
TmpString = TmpString & Pro &_
vbCrlf & vbTab & "Private Sub Class_Initialize()" &_
vbCrlf & vbTab & vbTab & "Set db = New Oledb" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = New Data" & Table & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbTab & "Private Sub Class_Terminate()" &_
vbCrlf & vbTab & vbTab & "Set db = Nothing" & _
vbCrlf & vbTab & vbTab & "Set " & LTable & " = Nothing" & _
vbCrlf & vbTab & "End Sub" &_
vbCrlf & vbCrLf& "End Class" & vbCrLf & "%" & Chr(62)
Call SaveEventClass(Table, TmpString)
End Sub
Private Sub SaveDataClass(ByVal Table, ByRef Content)
Call Save(DataDir, Table, Content)
End Sub
Private Sub SaveDalClass(ByVal Table, ByRef Content)
Call Save(DalDir, Table, Content)
End Sub
Private Sub SaveBllClass(ByVal Table, ByRef Content)
Call Save(BllDir, Table, Content)
End Sub
Private Sub SaveEventClass(byVal Table, ByRef Content)
Call Save(EventDir, Table, Content)
End Sub
Private Sub Save(ByVal Dir, ByVal FileName, ByRef Content)
Dim Path : Path = Server.MapPath(Dir & FileName & ".asp")
Set File = FSO.OpenTextFile(Path, 2, true)
File.Write Content
Response.Write("<li>" & Path & "</li>")
End Sub
Private Sub DetectDir(DirName)
Dim Path : Path = Server.MapPath(DirName)
If Not FSO.FolderExists(Path) Then
FSO.CreateFolder(Path)
End If
End Sub
Private Sub OpenConn()
If Conn.State = adStateClosed Then
Conn.Open ConnectionString
End If
End Sub
Private Sub CloseConn()
If Conn.State <> adStateClose Then
Conn.Close()
Set Conn = Nothing
End If
End Sub
Private Sub CloseRs()
If Rs.State <> adStateClose Then
Rs.Close()
Set Rs = Nothing
End If
End Sub
Private Sub CreateSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateSelectOneSp(Table, Key, Columns)
Call CreateSelectTopSp(Table, Key, Columns)
Call CreateSelectAllSp(Table, Key, Columns)
Call CreateInsertSp(Table, Key, Columns)
Call CreateUpdateSp(Table, Key, Columns)
Call CreateDeleteSp(Table, Key, Columns)
End Sub
Private Sub CreateSelectOneSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateProcedure(Table & "_SelectOne", "SELECT " & Key & "," & Columns & " FROM [" & Table & "] WHERE " & Key & " = [@" & Key & "]")
End Sub
Private Sub CreateSelectTopSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateProcedure(Table & "_SelectTop", "SELECT TOP 10 " & Key & "," & Columns & " FROM [" & Table & "]")
End Sub
Private Sub CreateSelectAllSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateProcedure(Table & "_SelectAll", "SELECT " & Key & "," & Columns & " FROM [" & Table & "]")
End Sub
Private Sub CreateInsertSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateProcedure(Table & "_Insert", "SELECT " & Key & "," & Columns & " FROM [" & Table & "]")
End Sub
Private Sub CreateUpdateSp(ByVal Table, ByVal Key, ByVal Columns)
Dim ar : ar = Split(Columns, ",")
Dim sql : sql = "UPDATE [" & Table & "] SET "
Dim i, l : l = UBound(ar)
For i = 0 To l
If i = l Then
sql = sql & Table & "." & ar(i) & " = [@" & ar(i) & "] "
Else
sql = sql & Table & "." & ar(i) & " = [@" & ar(i) & "], "
End If
Next
sql = sql & "WHERE " & Table & "." & Key & " = [@" & Key & "]"
Call CreateProcedure(Table & "_Update", sql)
End Sub
Private Sub CreateDeleteSp(ByVal Table, ByVal Key, ByVal Columns)
Call CreateProcedure(Table & "_Delete", "DELETE * FROM [" & Table & "] WHERE " & Key & " = [@" & Key & "]")
End Sub
Private Function ReadTable()
Dim TmpTable
OpenConn()
Set Rs = Conn.openSchema(20, Array(Empty, Empty, Empty,"TABLE"))
Rs.MoveFirst()
Do While Not Rs.EOF
TmpTable = TmpTable & "," & Rs("TABLE_NAME")
Rs.MoveNext()
Loop
ReadTable = Split(Mid(TmpTable, 2), ",")
End Function
Private Function ReadColumn(ByVal TableName)
OpenConn()
Set ReadColumn = Conn.openSchema(4, Array(Empty, Empty, TableName, Empty))
End Function
Private Sub CreateProcedure(ByVal SpName, ByVal SpSql)
OpenConn()
Set cmd.ActiveConnection = Conn
cmd.CommandText = SpSql
Set Cat.ActiveConnection = Conn
Cat.Procedures.Append SpName, Cmd
End Sub
End Class
Dim g : Set g = New Generator
g.DataPath = "data.mdb"
g.GenerateByTable("News")
’g.CreateTable
Set g = Nothing
%>

转自：http://space.flash8.net/bbs/thread-247879-1-1.html

]]>