大佛的博客...[No Comment]

特斯塔

特色特色沙

发布于 2006年1月14日 10:27 由 koaqiu 有 0 篇评论

3.表单数据读取/校验按上一步骤，表单将转交给下面的实例类处理： /Action/News.asp    <% Class ActionNews Priv

发布于 2006年1月13日 13:31 由我佛山人有 0 篇评论

ASP三层架构中的事件处理/表单提交（２）

2.表单处理中转/工厂
在（１）中可以看到表单设置中的action值是/action/?actionID=<%=action%>,其实就是提交到这个文件（index.asp作为网站默认文档的情况下）
/Action/index.asp

<!--#include file="ActionFactory.asp"-->
<%
Dim af : Set af = New ActionFactory
With af
    .Execute()
End With
Set af = Nothing
%>

这里实例化ActionFactory类，它的代码如下：

<!--#include virtual="/Class/Xml//XmlReader.asp"-->
<%
Class ActionFactory
    Private Xml
    Private IID
    Private IPath

    Public Property Let Path(ByVal value)
        IPath = value
    End Property
    Public Property Get Path()
        If IsNull(IPath) Or IsEmpty(IPath) Then
            IPath = Request.ServerVariables("HTTP_REFERER")
            If IsNull(IPath) Or IsEmpty(IPath) Then
                Response.Redirect("/index.asp")
            End If
            Call RePath(IPath)
        End If
        Path = IPath
    End Property

    Public Property Let ID(ByVal value)
    End Property
    Public Property Get ID()
        If IsNull(IID) Or IsEmpty(IID) Then
            IID = Request.QueryString("actionID")
            If IsNull(IID) Or IsEmpty(IID) Then
                Response.Redirect("/index.asp")
            End If
        End If
        ID = LCase(IID)
    End Property

    Public Function Execute()
        Xml.Load("/common/Validation.xml")
        Dim Node : Set Node = Xml.SelectSingleNode("/formset/form[@action='" & ID & "' and @path='" & Path & "']")
        Server.Transfer(Node.getAttribute("class") & ".asp")
    End Function


    Private Sub Class_initialize()
        Set Xml = New XmlReader
    End Sub
    Private Sub Class_Terminate()
        Set Xml = Nothing
    End Sub

    Private Sub RePath(ByRef value)
        Dim tmpvalue : tmpvalue = value
        Dim Re : Set Re = New RegExp
        Re.Pattern = "\?.*"
        tmpvalue = Re.Replace(tmpvalue, "")
        If Request.ServerVariables("HTTPS") = "on" Then
            Re.Pattern = "https://" & Request.ServerVariables("SERVER_NAME") & "(:" & Request.ServerVariables("SERVER_PORT") &")?" 
        Else
            Re.Pattern = "http://" & Request.ServerVariables("SERVER_NAME") & "(:" & Request.ServerVariables("SERVER_PORT") &")?" 
        End If
        tmpvalue = Re.Replace(tmpvalue, "")
        Set Re = Nothing
        value = LCase(tmpvalue)
    End Sub
End Class
%>

这里读取XML配置文件，获取指定节点的class属性值，把表单称交给指定的方法处理，XML文档内容如下：

<?xml version="1.0" encoding="gb2312"?>
<formset>

    <form name="newsinsert" path="/admin/newsform.asp" class="news" action="insert">
        <item name="Title" dataType="Limit" min="1" max="30" msg="新闻标题必须填写且在30位以内" />
        <item name="Hits" dataType="Number" msg="点击数只允许为正整数" />
    </form>

    <form name="newsedit" path="/admin/newsform.asp" class="news" action="edit">
        <item name="Title" dataType="Limit" min="1" max="30" msg="新闻标题必须填写且在30位以内" />
        <item name="Content" dataType="Require" msg="请填写内容" />
        <item name="Hits" dataType="Number" msg="点击数只允许为正整数" />
    </form>

    <form name="newslist" path="/admin/newslist.asp" class="news" action="delete">
        <item name="NewsIDs" dataType="Group" min="1" msg="请选择要删除的新闻" />
    </form>

    <form name="modify" path="/admin/changepassword.asp" class="admin" action="modify">
        <item name="oldPassword" dataType="Require" msg="请填写旧密码" />
        <item name="Password" dataType="SafeString" msg="请填写新密码" />
        <item name="RePassword" dataType="Repeat" to="Password" msg="两次输入的密码不一致" />
        <item name="vCode" dataType="Limit" min="5" max="5" msg="请填写5位的验证码" />
    </form>

    <form name="classinsert" path="/admin/classform.asp" class="class" action="insert">
        <item name="ClassName" dataType="Require" msg="必须填写类名" />
        <item name="OrderID" dataType="Number" msg="排序号只允许为正整数" />
    </form>

    <form name="classedit" path="/admin/classform.asp" class="class" action="edit">
        <item name="ClassName" dataType="Require" msg="必须填写类名" />
        <item name="OrderID" dataType="Number" msg="排序号只允许为正整数" />
    </form>

    <form name="login" path="/admin/login.asp" class="admin" action="login">
        <item name="UserName" dataType="Require" msg="请填写用户名" />
        <item name="Password" dataType="Require" msg="请填写密码" />
        <item name="vCode" dataType="Limit" min="5" max="5" msg="请填写5位的验证码" />
    </form>

</formset>

（未完待续）

发布于 2006年1月13日 13:30 由我佛山人有 0 篇评论

ASP三层架构中的事件处理/表单提交（１）

1.表单
/Admin/NewsForm.asp

<!--#include virtual="/Class/Package.asp"-->
<!--#include virtual="/Class/Bll/Admin.asp"-->
<!--#include virtual="/Class/Bll/News.asp"-->
<!--#include virtual="/Class/Bll/Class.asp"-->
<!-- #include file="FCKeditor/fckeditor.asp" -->
<%
Dim admin : Set admin = New BllAdmin
admin.CheckLogin()
Set admin = Nothing
Dim news : Set news = New BllNews
Dim action : action = "insert"
Dim id : id = Request.QueryString("NewsID")
If id <> "" Then
    action = "edit"
End If
If action = "edit" Then
    With news
        .NewsID = id
        .SelectOne()
        id = .NewsID
    End With
End If
%>
<HTML>
<title>后台管理</title>
<meta http-equiv="Content-Type" content="text/html; charset=gb2312">
<link href="css/main.css" rel="stylesheet" type="text/css">
<script type="text/javascript" src="js/validator.js"></script>
<script type="text/javascript" src="js/cmd.js"></script>
<body>
<form id="news<%=action%>" method="post" action="/action/?actionID=<%=action%>" onSubmit="return Validator.Validate(this, 2)">
<table width="98%" border="0" align="center" cellpadding="0" cellspacing="0">
<tr>
<td><table width="100%" border="0" cellpadding="0" cellspacing="0" class="title">
<tr>
<td width="40%">信息发布</td>
</tr>
</table></td>
</tr>
<tr>
<td><table width="100%" border="0" cellpadding="0" cellspacing="0">
<tr class="add1">
<th> 标题：</th>
<td><input type="text" name="Title" class="input" dataType="Require" msg="必须填写标题" value="<%=news.Title%>"> </td>
</tr>
<tr class="add">
<th> 分类：</th>
<td>
            <select name="ClassID">
            <%
            Dim cls : Set cls = New BllClass
            If action = "edit" Then cls.ClassID = news.ClassID
            Response.Write cls.Tree
            Set cls = Nothing
            %>
        </select>
        </td>
</tr>
<tr class="add1">
<th colspan="2" align="center">
        <%
        Dim editor : Set editor = New FCKeditor
        editor.value = news.Content
        editor.Width = "98%"
        editor.Height = 300
        editor.Create "Content"
        %></th>
</tr>
<tr class="add">
<th>图片：</th>
<td><input name="Picture" type="text" id="Picture" value="<%=news.Picture%>"><input onclick="SelectImage('Picture')" type="button" value="选择图片"></td>
</tr>
<tr class="add1">
<th>附加：</th>
<td><label>推荐
<input name="IsCommend" type="checkbox" id="IsCommend" value="1"<%If news.IsCommend = True Then Response.Write " checked"%>>
初始点击数：
<input type="text" size="5" name="Hits" datatype="Number" msg="点击数只能为整数" value="<%=news.Hits%>">
</label></td>
</tr>

</table>
<table width="100%" border="0" cellpadding="0" cellspacing="0" class="page">
<tr>
<td width="40%">     <input type="hidden" value="<%=id%>" name="NewsID">
            <input type="image" name="ibModify" src="images/enter.gif">
<img src="images/reset.gif" width="46" height="20" style="CURSOR:hand" onClick="document.forms[0].reset()"></td>
</tr>
</table></td>
</tr>
</table>
</form>
</body>
</HTML>
<%
Set news = Nothing
%>

其中Package.asp代码为：

<!--#include virtual="/Class/validator.asp"-->
<!--#include virtual="/Class/Exception.asp"-->
<!--#include virtual="/Class/State/Cache.asp"-->
<!--#include virtual="/Class/State/Session.asp"-->
<!--#include virtual="/Class/State/Cookie.asp"-->
<!--#include virtual="/Class/Pager.asp"-->
<!--#include virtual="/Class/Text/Utility.asp"-->
<!--#include virtual="/Class/Oledb.asp"-->


（未完待续）

发布于 2006年1月13日 13:25 由我佛山人有 0 篇评论

[太极经典]留住我吧

[听不到的话点这儿下载]

留住我吧

又望你多一眼
泪缓缓的淌下
又是分开的一刹那
实在我心中有
极难言的说话
但愿你一一知道吗
留住我吧
留住我好吗
你说过跟他早已不像话
你说过再不想见他
你说过喜欢听我的梦话
此刻留住我
可以吗
但是我永不要
在含糊境况下
利用你跟他的变化
若是你爱一个
就完全的爱吧
莫问再应不应记挂

留住我吧
留住我好吗
告诉我简单一句心内话
告诉我若要我留下
告诉我让我知道怎做吧
今天留住我
可以吗

难道这梦
已经消失变化
告诉我简单一句心内话
告诉我心愿别再盼
告诉我让我知道怎做吧
一生留住我

八十年代乐队文化盛行，造就了Beyong，也成就了太极。这是我很喜欢的太极乐队的一首歌，雷有辉的声音空灵而不缥缈，柔情万千又不失阳刚，堪称硬派情歌的代表作。

发布于 2006年1月12日 13:22 由我佛山人有 2 篇评论

ASP伪三层架构简单实例

1.数据模型层：
/class/Data/News.asp
<%
Class DataNews

    Private INewsID
    Private IClassID
    Private IClassName
    Private ITitle
    Private IContent
    Private IPicture
    Private IIsCommend
    Private IHits
    Private IPostDate

    'NewsID
    Public Property Let NewsID(ByVal value)
        INewsID = value
    End Property
    Public Property Get NewsID()
        NewsID = INewsID
    End Property

    'ClassID
    Public Property Let ClassID(ByVal value)
        IClassID = value
    End Property
    Public Property Get ClassID()
        ClassID = IClassID
    End Property

    'ClassName
    Public Property Let ClassName(ByVal value)
        IClassName = value
    End Property
    Public Property Get ClassName()
        ClassName = IClassName
    End Property

    'Title
    Public Property Let Title(ByVal value)
        ITitle = value
    End Property
    Public Property Get Title()
        Title = ITitle
    End Property

    'Content
    Public Property Let Content(ByVal value)
        IContent = value
    End Property
    Public Property Get Content()
        Content = IContent
    End Property

    'Picture
    Public Property Let Picture(ByVal value)
        IPicture = value
    End Property
    Public Property Get Picture()
        Picture = IPicture
    End Property

    'IsCommend
    Public Property Let IsCommend(ByVal value)
        IIsCommend = value
    End Property
    Public Property Get IsCommend()
        IsCommend = IIsCommend
    End Property

    'Hits
    Public Property Let Hits(ByVal value)
        IHits = value
    End Property
    Public Property Get Hits()
        Hits = IHits
    End Property

    'PostDate
    Public Property Let PostDate(ByVal value)
        IPostDate = value
    End Property
    Public Property Get PostDate()
        PostDate = IPostDate
    End Property

    Private Sub Class_Initialize()
    End Sub
    Private Sub Class_Terminate()
    End Sub

End Class
%>

2.数据访问层：
/Class/Dal/News.asp

<!--#include virtual="/Class/Data/News.asp"-->
<%
Class DalNews

    Private db
    Private news

    'NewsID
    Public Property Let NewsID(ByVal value)
        news.NewsID = value
    End Property
    Public Property Get NewsID()
        NewsID = news.NewsID
    End Property

    'ClassID
    Public Property Let ClassID(ByVal value)
        news.ClassID = value
    End Property
    Public Property Get ClassID()
        ClassID = news.ClassID
    End Property

    'ClassName
    Public Property Let ClassName(ByVal value)
        news.ClassName = value
    End Property
    Public Property Get ClassName()
        ClassName = news.ClassName
    End Property

    'Title
    Public Property Let Title(ByVal value)
        news.Title = value
    End Property
    Public Property Get Title()
        Title = news.Title
    End Property

    'Content
    Public Property Let Content(ByVal value)
        news.Content = value
    End Property
    Public Property Get Content()
        Content = news.Content
    End Property

    'Picture
    Public Property Let Picture(ByVal value)
        news.Picture = value
    End Property
    Public Property Get Picture()
        Picture = news.Picture
    End Property

    'IsCommend
    Public Property Let IsCommend(ByVal value)
        news.IsCommend = value
    End Property
    Public Property Get IsCommend()
        IsCommend = news.IsCommend
    End Property

    'Hits
    Public Property Let Hits(ByVal value)
        news.Hits = value
    End Property
    Public Property Get Hits()
        Hits = news.Hits
    End Property

    'PostDate
    Public Property Let PostDate(ByVal value)
        news.PostDate = value
    End Property
    Public Property Get PostDate()
        PostDate = news.PostDate
    End Property

    Public Function SelectOne()
        Dim rs : Set rs = db.ExecuteSp("News_SelectOne", NewsID)
        If Not (rs.BOF OR rs.EOF) Then
         With Me
         .NewsID = rs("NewsID")
         .ClassID = rs("ClassID")
         .ClassName = rs("ClassName")
         .Title = rs("Title")
         Dim tmpContent : tmpContent = rs("Content")
.Content = tmpContent
         .Picture = rs("Picture")
         .IsCommend = rs("IsCommend")
         .Hits = rs("Hits")
         .PostDate = rs("PostDate")
         End With
         SelectOne = True
        Else
         SelectOne = False
        End If
    End Function

    Public Function SelectTop(ByVal iCount, ByVal iClassID)
        Set SelectTop = db.Execute("SELECT TOP " & iCount & " NewsID, News.ClassID, Class.ClassName, Title, Content, Picture, IsCommend, Hits, PostDate FROM [News] LEFT JOIN [Class] ON [Class].[ClassID] = [News].[ClassID] WHERE News.[ClassID] = " & iClassID & " ORDER BY NewsID DESC")
    End Function

    Public Function SelectAll()
        Set SelectAll = db.ExecuteDataTableSp("News_SelectAll", Null)
    End Function

    Public Function SelectAllByClassID()
        Set SelectAllByClassID = db.ExecuteDataTableSp("News_SelectAllByClassID", ClassID)
    End Function

    Public Function Insert()
        NewsID = db.InsertSp("News_Insert", Array(ClassID, Title, Content, Picture, IsCommend, Hits))
        Insert = NewsID
    End Function

    Public Function Update()
        Update = db.ExecuteNonQuerySp("News_Update", Array(ClassID, Title, Content, Picture, IsCommend, Request.Form("Hits"), NewsID)) > 0
    End Function

    Public Function Delete()
        Delete = db.ExecuteNonQuerySp("News_Delete", NewsID) > 0
    End Function

    Public Function BatchDelete(ByVal NewsIDs)
        BatchDelete = db.ExecuteNonQuery("DELETE * FROM [News] WHERE NewsID IN (" & NewsIDs & ")")
    End Function

    Public Function TopPicNews(ByVal iClassID)
        Set TopPicNews = db.ExecuteDataTableSp("News_SelectTopPic", iClassID)
    End Function

    Private Sub Class_Initialize()
        Set db = New Oledb
        Set news = New DataNews
    End Sub
    Private Sub Class_Terminate()
        Set db = Nothing
        Set news = Nothing
    End Sub

End Class
%>

3.业务逻辑层：
/Class/Bll/News.asp

<!--#include virtual="/Class/Dal/News.asp"-->
<%
Class BllNews

    Private v
    Private e
    Private news

    'NewsID
    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

    'ClassID
    Public Property Let ClassID(ByVal value)
        If Not IsEmpty(value) And v.IsNum(v.SafeNo(value)) Then
            news.ClassID = CInt(v.SafeNo(value))
        Else
            news.ClassID = 0
            e.Message = "ClassID参数错误"
        End If
    End Property
    Public Property Get ClassID()
        ClassID = news.ClassID
    End Property

    'ClassName
    Public Property Let ClassName(ByVal value)
        news.ClassName = value
    End Property
    Public Property Get ClassName()
        ClassName = news.ClassName
    End Property

    'Title
    Public Property Let Title(ByVal value)
        If v.Limit(value, 1, 30) Then
            news.Title = value
        Else
            If IsNull(value) or IsEmpty(value) Or value = "" Then
                news.Title = ""
                e.Message = "标题不允许为空"
            Else
                news.Title = Left(value, 30)
                e.Message = "标题字符长度超过30"
            End If
        End If
    End Property
    Public Property Get Title()
        Title = news.Title
    End Property

    'Content
    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

    'Picture
    Public Property Let Picture(ByVal value)
        news.Picture = value
    End Property
    Public Property Get Picture()
        Picture = news.Picture
    End Property

    'IsCommend
    Public Property Let IsCommend(ByVal value)
        news.IsCommend = CBool(value)
    End Property
    Public Property Get IsCommend()
        IsCommend = news.IsCommend
    End Property

    'Hits
    Public Property Let Hits(ByVal value)
        If Not IsEmpty(value) And v.IsNum(v.SafeNo(value)) Then
            news.Hits = CInt(v.SafeNo(value))
        Else
            news.Hits = 0
            e.Message = "点击数设置错误"
        End If
    End Property
    Public Property Get Hits()
        Hits = news.Hits
        If IsEmpty(news.Hits) Then Hits = 0
    End Property

    'PostDate
    Public Property Let PostDate(ByVal value)
        news.PostDate = value
    End Property
    Public Property Get PostDate()
        PostDate = FormatDateTime(CDate(news.PostDate), 1)
    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(ByVal iCount, ByVal iClassID)
        Set SelectTop = news.SelectTop(iCount, iClassID)
    End Function

    Public Function SelectAll()
        Set SelectAll = news.SelectAll()
    End Function

    Public Function SelectAllByClassID()
        Set SelectAllByClassID = news.SelectAllByClassID()
    End Function

    Public Sub Insert()
        ClassID = ClassID
        Title = Title
        Content = Content
        Picture = Picture
        IsCommend = IsCommend
        Hits = Hits
        e.Target = "/admin/NewsForm.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

    Public Sub ShowTopNews(ByVal iCount, ByVal iClassID)
        Dim Rs : Set Rs = SelectTop(iCount, iClassID)
        If Not (Rs.BOF Or Rs.EOF) Then
%>
<TABLE cellSpacing=0 cellPadding=0 width=330 border=0>
<TBODY>
<%
            While Not Rs.EOF
%>
<TR>
<TD height=20><IMG style="MARGIN-RIGHT: 6px" 
height=3 src="images/mt02_i01.gif" width=4 
align=absMiddle><A 
href="Detail.asp?ID=<%=Rs("NewsID")%>" target="_blank"><%=Rs("Title")%></A><FONT 
color=#008f7e>/<%=FormatDate(Rs("PostDate"))%></FONT></TD>
</TR>
<%
                Rs.MoveNext()
            Wend
            Set Rs = Nothing
%>
</TBODY>
</TABLE>
<%
        End If
    End Sub


    Public Sub ShowTopPicNews(ByVal iCount, ByVal iClassID)
        Dim Rs : Set Rs = SelectTop(iCount, iClassID)
        Call ListRow(2, 2, Rs)        
    End Sub

    Public Function TopPicNews(ByVal iClassID)
        Set TopPicNews = news.TopPicNews(iClassID)
    End Function

    Private Sub Class_Initialize()
        Set v = New Validator
        Set e = New Exception
        Set news = New DalNews
    End Sub
    Private Sub Class_Terminate()
        Set v = Nothing
        Set e = Nothing
        Set news = Nothing
    End Sub

    Private Function FormatDate(ByVal daPostDate)
        daPostDate = CDate(daPostDate)
        FormatDate = Right(Year(daPostDate), 2) & "." & Month(daPostDate) & "." & Day(daPostDate)
    End Function

    Public Function ListRow(ByVal x,ByVal y,ByVal Rs)
     With Response
     If (Rs.Eof or Rs.Bof) Then Exit Function
     If x <=0 Then Exit Function End If
     If y<=0 Then y = 0 End If
     For i = 0 to x
        .Write "<tr>" & vbCrlf 
        For j = 0 to y 
            If Not Rs.Eof Then
                .Write "<TD width=""110"" height=100 align=""center""><img src=""" & rs("Picture") & """ width=""100"" height=""75""><br><a href=""Detail.asp?id=" & rs("NewsID") & """>" & rs("Title") & "</a></TD>" & vbCrlf
            Else
                .Write "<td width=""110"" height=""100"">&nbsp;</td>" & vbCrlf
            End If
            Rs.MoveNext()
            If (Rs.Eof or Rs.Bof) Then 
                If j < y Then
                    .Write Replace(Space(y - j), " ", "<td>&nbsp;</td>" & vbCrlf)
                End If
                .Write "</tr>" & vbCrlf
                Exit Function
            End If
        Next 
        .Write "</tr>" & vbCrlf
        Next 
     End With 
    End Function

End Class
%>

发布于 2006年1月12日 13:18 由我佛山人有 2 篇评论

敝帚自珍：ASP工具类（字符串处理）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, "<", "&lt;")
            S = Replace(S, ">", "&gt;")
            S = Replace(S, " ", "&nbsp;")
            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, """", "&#34;")
        Str = Replace(Str, "'", "&#39;")
        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

    Public Function getHostName ()
        Dim hostName
        hostName = Request.ServerVariables("HTTP_HOST")
        If Not IsNull(Request.ServerVariables("HTTP_X_FORWARDED_HOST")) Then
            If Len(Trim(Request.ServerVariables("HTTP_X_FORWARDED_HOST"))) > 0 Then
                hostName = Request.ServerVariables("HTTP_X_FORWARDED_HOST")
            End If 
        End If
        getHostName = hostName
    End Function

End Class
%>
<%
Dim Util : Set Util = New Utility
%>

发布于 2006年1月12日 13:15 由我佛山人有 0 篇评论

敝帚自珍：ASP状态封装类Cache、Cookie & Session

CacheState类，建议实例化时用名Cache

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

CookieState类，建议实例化时用名Cookie

<%
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类，建议实例化时用名Session

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

发布于 2006年1月12日 12:03 由我佛山人有 0 篇评论

敝帚自珍：ASP读取XML类XmlReader

这个类很简单，只提供读取XML文档的方法，但可以根据自己需要自行扩展

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

发布于 2006年1月12日 12:02 由我佛山人有 0 篇评论

敝帚自珍：ASP数据校验类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+)*{logContent}quot;, Str)
    End Function

    Public Function IsUrl(ByVal Str)
        IsUrl = Test("^http:\/\/[A-Za-z0-9]+\.[A-Za-z0-9]+[\/=\?%\-&_~`@[\]\':+!]*([^<>""])*{logContent}quot;, Str)
    End Function

    Public Function IsNum(ByVal Str)
        IsNum= Test("^\d+{logContent}quot;, Str)
    End Function

    Public Function IsQQ(ByVal Str)
        IsQQ = Test("^[1-9]\d{4,8}{logContent}quot;, Str)
    End Function

    Public Function IsZip(ByVal Str)
        IsZip = Test("^[1-9]\d{5}{logContent}quot;, Str)
    End Function

    Public Function IsIdCard(ByVal Str)
        IsIdCard = Test("^\d{15}(\d{2}[A-Za-z0-9])?{logContent}quot;, Str)
    End Function

    Public Function IsChinese(ByVal Str)
        IsChinese = Test("^[\u0391-\uFFE5]+{logContent}quot;, Str)
    End Function

    Public Function IsEnglish(ByVal Str)
        IsEnglish = Test("^[A-Za-z]+{logContent}quot;, Str)
    End Function

    Public Function IsMobile(ByVal Str)
        IsMobile = Test("^((\(\d{3}\))|(\d{3}\-))?13\d{9}{logContent}quot;, Str)
    End Function

    Public Function IsPhone(ByVal Str)
        IsPhone = Test("^((\(\d{3}\))|(\d{3}\-))?(\(0\d{2,3}\)|0\d{2,3}-)?[1-9]\d{6,7}{logContent}quot;, 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}){logContent}quot;, Str)
        Else 
            IsDateFormat = Test("^(\d{1,2})([-./])(\d{1,2})\\2((\d{4})|(\d{2})){logContent}quot;, 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*and\s*\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+)[\D\d]*{logContent}quot;, ""))
        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
%>

发布于 2006年1月12日 11:57 由我佛山人有 0 篇评论

敝帚自珍：ASP异常提示类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>", "\n")
        words = Replace(words, "</li>", "")
        words = Replace(words, vbCrLf, "")
        words = "提示信息：\t\t\t" & words
%>
        <script type="text/javascript">
        <!--
            alert("<%=words%>")
            <%=Me.Window%>.location = "<%=Me.Target%>"
        //-->
        </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>&nbsp;</TD>
                    </TR>
                    <TR>
                     <TD align="center"><a href="BLOCKED SCRIPThistory.back()">[返回]</a> <a href="/">[首页]</a> </TD>
                    </TR>
                 </TBODY>
                </TABLE>
             </TD>
            </TR>
         </TBODY>
        </TABLE>
<% If Redirect Then%>        <script type="text/javascript">
        <!--
            setTimeout("<%=Me.Window%>.location='<%=Me.Target%>'",<%=Me.TimeOut%>)
        //-->
        </script><%end If%>
<%
    Case 2
        Call Alert()
    Case Else
        Response.Write Message
    End Select
        Response.End()
    End Sub
End Class
%>

发布于 2006年1月12日 11:53 由我佛山人有 0 篇评论

凑个热闹小MM一个

小MM 照片一张：

{图片1}

发布于 2006年1月11日 17:54 由 koaqiu 有 0 篇评论

<%
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 ExecuteDataTableSp1(ByVal SpName, ByVal Params)
        OpenConn()
        Dim Rs1 : Set Rs1 = Server.CreateObject("ADODB.RecordSet")
        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 Rs1.Open(SpStr, Conn, 1, 1, adCmdStoredProc)
        Set ExecuteDataTableSp1 = Rs1
        Set Rs1 = Nothing
    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
            'Response.Write SpName & "," & Join(Params, "-")
            'Response.End
            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
%>

SqlClient　还在测试，从Oledb改过来的

Dim adCmdSPStoredProc    : adCmdSPStoredProc = 4
Dim adParamReturnValue    : adParamReturnValue = 4
Dim adParaminput        : adParaminput = 1
Dim adParamOutput        : adParamOutput = 2
Dim adInteger            : adInteger = 3
Dim adVarChar            : adVarChar = 200

Class SqlClient

    
    Private IHost
    Private IUID
    Private IPWD
    Private IDatabase
    Private IConnectionString

    Private Conn
    Private Cmd
    Private Param
    Private Rs

    Public Property Let Host(ByVal Value)
        IHost = Value
    End Property
    Public Property Get Host()
        Host = IHost
    End Property

    Public Property Let UID(ByVal Value)
        IUID = Value
    End Property
    Public Property Get UID()
        UID = IUID
    End Property

    Public Property Let PWD(ByVal Value)
        IPWD = Value
    End Property
    Public Property Get PWD()
        PWD = IPWD
    End Property

    Public Property Let Database(ByVal Value)
        IDatabase = Value
    End Property
    Public Property Get Database()
        Database = IDatabase
    End Property

    Public Property Let ConnectionString(ByVal Value)
        IConnectionString = Value
    End Property
    Public Property Get ConnectionString()
        If IsEmpty(IConnectionString) Then
            IConnectionString = "Driver={SQL Server};server=" & Me.Host & ";Uid=" & Me.UID & ";Pwd=" & Me.PWD & ";Database=" & Me.Database
        End If
        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 ExecuteDataTableSp1(ByVal SpName, ByVal Params)
        OpenConn()
        Dim Rs1 : Set Rs1 = Server.CreateObject("ADODB.RecordSet")
        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 Rs1.Open(SpStr, Conn, 1, 1, adCmdStoredProc)
        Set ExecuteDataTableSp1 = Rs1
        Set Rs1 = Nothing
    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
            'Response.Write SpName & "," & Join(Params, "-")
            'Response.End
            Call .Execute(ExecuteNonQuerySp, Params)
        End With
    End Function

    Public Function ExecuteSpReturnValue(ByVal SpName, ByVal Params, ByRef ReturnValue)
        Dim i, l
        With Cmd
            Set .ActiveConnection = OpenConn()
            .CommandText = SpName
            .CommandType = &H0004
            .Prepared = True
            If IsArray(Params(0)) Then
                l = UBound(Params)
                For i = 0 To l
                    'Response.Write Join(Params(i), "-") & "
"
                    .Parameters.Append .CreateParameter(Params(i)(0), Params(i)(1), Params(i)(2), Params(i)(3), Params(i)(4))
                Next
            Else
                .Parameters.Append .CreateParameter(Params(0), Params(1), Params(2), Params(3), Params(4))
            End If
            .Execute()
            Dim pCount : pCount = .Parameters.Count
            If IsArray(ReturnValue) Then
                l = UBound(ReturnValue)
                For i = 0 To l
                    ReturnValue(i) = .Parameters.Item(pCount-1 - (l - i))
                Next
            Else
                ReturnValue = .Parameters.Item(pCount-1)
                'Response.Write ReturnValue
                'Response.End
            End If
        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")
        With Me
            .Host = "(local)"
            .UID = "sa"
            .PWD = "
            .Database = "Northwind"
        End With
    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

发布于 2006年1月10日 15:19 由我佛山人有 1 篇评论

公告

随笔分类

文章分类

存档

搜索

订阅

广告位招租

特斯塔

ASP三层架构中的事件处理/表单提交（３）