论坛: 网站建设 标题: 发布一个刚刚完成的ASP数据库操作类 复制本贴地址    
作者: NetFog [q70213526]    版主   登录
代码:

<%
''===============================================
''@Date            2006-6-5
''@Author          NetFog
''@ModifyTime      2006-6-5
''@Desc            数据库操作类
''===============================================
Class Cls_ADO
Private Conn          '数据库连接对象
Private ConnStr        '数据库连接字符串
Private DbType        '数据库存类型,AC表示MS ACCESS,MSSQL表示为MS SQL Server
Private DbName        '数据库名
Private DbPath        '为AC数据库时,数据库文件的安装目录,必须无Root_Path
Private DbServerIP    '数据库服务器IP
Private DbUserName    '数据库连接用户名
Private DbUserPWD      '数据库存连接密码
Private Record        'RecordSet对象
Private Cmd            'Commond对象
Private QueryTimes    'SQL查询次数
Private IsError        '是否出错

''===========================================
''@name      Class_Initialize
''@desc      初始化类
''===========================================
Private Sub Class_Initialize()
DbType = "AC"
DbPath = ""
QueryTimes = 0
IsError = False
End Sub

''===========================================
''@name      GetConnStr
''@desc      取得数据库连接字符串
''===========================================
Private Function GetConnStr()
Select Case DbType
Case "AC"
ConnStr = "Provider = Microsoft.Jet.OLEDB.4.0; Data Source =" & Server.MapPath(DbPath & DbName & ".mdb")
Case "MSSQL"
ConnStr = "Driver={SQL Server};Server=" & DbServerIP & "; UID=" & DbUserName & ";Password=" & DbUserPWD & ";DataBase=" & DbName
Case Else
ConnStr = "Provider = Microsoft.Jet.OLEDB.4.0; Data Source =" & Server.MapPath(DbPath & DbName & ".mdb")
End Select
GetConnStr = ConnStr
End Function

''===========================================
''@name      DbType
''@desc      设置数据库类型
''===========================================
Public Property Let Db_Type(ByVal vDbType)
DbType = Ucase(vDbType)
End Property

''===========================================
''@name      Db_Path
''@desc      设置AC连接时的数据库路径,格式必须为"Data/"或者"./Data/",前必须无"/",后必须有
''===========================================
Public Property Let Db_Path(ByVal vDbPath)
DbPath = vDbPath
End Property

''===========================================
''@name      Db_Name
''@desc      设置数据库名
''===========================================
Public Property Let Db_Name(ByVal vDbName)
DbName = vDbName
End Property

''===========================================
''@name      Db_ServerIP
''@desc      设置数据库服务器IP
''===========================================
Public Property Let Db_ServerIP(ByVal vDbServerIP)
DbServerIP = vDbServerIP
End Property

''===========================================
''@name      Db_UserName
''@desc      设置数据库用户名
''===========================================
Public Property Let Db_UserName(ByVal vDbUserName)
DbUserName = vDbUserName
End Property

''===========================================
''@name      Db_UserPWD
''@desc      设置数据库用户密码
''===========================================
Public Property Let Db_UserPWD(ByVal vDbUserPWD)
DbUserPWD = vDbUserPWD
End Property

''===========================================
''@name      QueryTotal
''@desc      返回数据库查询次数
''===========================================
Public Property Get QueryTotal()
QueryTotal = QueryTimes
End Property

''===========================================
''@name      Err
''@desc      是否出错
''===========================================
Public Property Get Errs()
Errs = IsError
End Property

''===========================================
''@name      OpenADO
''@desc      打开数据库链接
''===========================================
Public Sub OpenADO()
Set Conn = Server.CreateObject("Adodb.Connection")
Conn.Open GetConnStr()
If (Err = True) Or (Conn.State = 0) then
  Err.Clear
  IsError = True
  Response.Write "数据库连接出错!"
  Response.End
End If
End Sub

''===========================================
''@name      CloseADO
''@desc      关闭数据库链接和Record对象
''===========================================
Public Sub CloseADO()
If IsObject(Record) Then Set Record = Nothing
If IsObject(Conn) Then
If Conn.State = 1 Then Conn.Close : Set Conn = Nothing
end if
End Sub

''===========================================
''@name      ExeSQL
''@desc      执行SQL语句
''===========================================
Public Sub ExeSQL(vExeSQL)
If IsError = False Then
Conn.Execute(vSQL)
If Err.Number = 0 Then IsError = False
QueryTimes = QueryTimes+1
end if
If Err.Number<>0 Then
Err.Clear
IsError = True
Response.Write "执行SQL语句出错"
Response.End
End If
End Sub

''===========================================
''@name      ExeInsert
''@desc      执行数据插入
''===========================================
Public Sub ExeInsert(ByVal vTable,ByVal vColumn,ByVal vValue)
Dim SQL,i
If (IsArray(vColumn) <> True) Or (IsArray(vValue) <> True) Or (Ubound(vColumn) <> Ubound(vValue)) Then
Response.Write "查询值的数目与目标字段中的数目不同或参数不是数组"
IsError = True
Response.End
Else
Set Cmd = Server.CreateObject("Adodb.Command")
Cmd.ActiveConnection = Conn
SQL = "Insert into " & vTable & " ("
For i=0 to Ubound(vColumn)
SQL = SQL & vColumn(i) & ","
Next
SQL = Left(SQL,Len(SQL)-1) & ") Values("
For i=0 to Ubound(vValue)
SQL = SQL & FormatSingleValueType(vValue(i)) & ","
Next
SQL = Left(SQL,Len(SQL)-1) & ")"
Cmd.CommandText = SQL
Cmd.Execute ,,1
If Err.Number = 0 Then IsError = False
QueryTimes = QueryTimes+1
If Err.Number <> 0 Then Err.Clear : IsError = True
If IsObject(Cmd) then Set Cmd = Nothing
End If
End Sub

''===========================================
''@name      ExeUpdate
''@desc      执行数据库存更新
''===========================================
Public Sub ExeUpdate(ByVal vTable,ByVal vColumn,ByVal vValue,ByVal vCondition)
Dim SQL,i
If (IsArray(vColumn) <> True) Or (IsArray(vValue) <> True) Or (Ubound(vColumn) <> Ubound(vValue)) Then
Response.Write "查询值的数目与目标字段中的数目不同或参数不是数组"
IsError = True
Response.End
Else
Set Cmd = Server.CreateObject("Adodb.Command")
Cmd.ActiveConnection = Conn
SQL = "Update " & vTable & " Set "
For i=0 to Ubound(vColumn)
SQl = SQL & vColumn(i) & " = " & FormatSingleValueType(vValue(i)) & ","
Next
SQL = Left(SQL,Len(SQL)-1) & " where "&vCondition
Cmd.CommandText = SQL
Cmd.Execute ,,1
If Err.Number = 0 Then IsError = False
QueryTimes = QueryTimes+1
If Err.Number <> 0 Then Err.Clear : IsError = True
If IsObject(Cmd) then Set Cmd = Nothing
End If
End Sub

''===========================================
''@name        ExeDelete
''@desc        删除数据库中的记录
''===========================================
Public Function ExeDelete(ByVal vTable,ByVal vCondition)
Dim SQL
Set Cmd = Server.CreateObject("Adodb.Command")
Cmd.ActiveConnection = Conn
SQL = "Delete From " & vTable & " Where " & vCondition
Cmd.CommandText = SQL
Cmd.Execute ,,1
If Err.Number = 0 Then IsError = False
QueryTimes = QueryTimes+1
If Err.Number <> 0 Then Err.Clear : IsError = True
If IsObject(Cmd) then Set Cmd = Nothing
End Function

''===========================================
''@name       ExeGetData
''@desc      返回二维数组,失败时为False.在记录很多时忌用,会占用大量内存
''===========================================
Public Function ExeGetData(ByVal vSQL)
Dim tmpArr
If IsObject(Record) Then Set Record = Nothing
Set Record = Server.CreateObject("Adodb.RecordSet")
Record.Open vSQL,Conn,1,1
QueryTimes = QueryTimes+1
If Err.Number<>0 Then
Err.Clear
TmpArr = False
IsError = True
Else
If Record.Eof Then
TmpArr = False
IsError = True
Else
TmpArr = Record.GetRows(-1)
End If
End If
ExeGetData = tmpArr
End Function

''===========================================
''@name      GetOneRecord
''@desc      取得一条记录
''===========================================
Public Function GetOneRecord(ByVal intNum,ByVal vSQL)
Dim TmpColumn
TmpColumn = True
TmpColumn = Conn.Execute(vSQL)(intNum)
QueryTimes = QueryTimes + 1
If Err.Number<>0 Or varType(TmpColumn) = 1 Then
Err.Clear
IsError = False
TmpColumn = False
End If
GetOneRecord = TmpColumn
End Function

''===========================================
''@name      FormatSingleValueType
''@desc      将非单个变量格式化,以便提交到数据库
''===========================================
Private Function FormatSingleValueType(ByVal vValue)
If IsNumeric(vValue) = true then
vValue = vValue
else
vValue = "'" & Replace(vValue,"'","&#39") & "'"
End If
FormatSingleValueType = vValue
End Function

End Class
%>





[此贴被 NetFog(q70213526) 在 06月06日21时55分 编辑过]

地主 发表时间: 06-06-06 18:31

回复: NetFog [q70213526]   版主   登录


[此贴被 NetFog(q70213526) 在 06月06日18时37分 编辑过]

B1层 发表时间: 06-06-06 18:33

回复: NetFog [q70213526]   版主   登录
将就一下。下面是调用。

通过ACCESS以及MSSQL数据库测试。

以下求全用AC数据库,数据库目录为Data
结构如下
表名:t
字段:1,2,3,4  这四个用数字命名字段,类型分别为"自动编号,文本,文本,日期"

数据插入示例
demoInsert.asp
代码:

<!--#include file="Class.ADO.asp"-->
<%
Set ADO = New Cls_ADO
With ADO
.Db_Type = "AC"
.Db_Path = "./Data/"
.Db_Name = "db1"
.Db_ServerIP = "(local)"
.Db_UserName = "sa"
.Db_UserPWD = "qiuzhi526"
end with
dim vColumn(2),vValue(2)
vTabel = "t"                            '设置要操作的表

'设置要操作的字段
vColumn(0) = "2"                     
vColumn(1) = "3"
vColumn(2) = "4"
'设置要操作的字段完毕

'设置待插入值
vValue(0) = "1111"           
vValue(1) = "a'bc,abc"
vValue(2) = now()
'设置待插值完毕

ADO.OpenADO                              '打开连接
ADO.ExeInsert vTabel,vColumn,vValue      '执行操作
ADO.CloseADO                            '关闭连接
Response.Write "数据库查询次数:--->&nbsp;"&ADO.QueryTotal&"次<br>"
Response.Write "是&nbsp;&nbsp;否&nbsp;&nbsp;出&nbsp;&nbsp;错:--->&nbsp;"&ADO.Errs&"&nbsp;&nbsp;<font color=red size=2>[False

表示未出错]</font>"
Set ADO = Nothing                        '注销
%>




[此贴被 NetFog(q70213526) 在 06月06日21时59分 编辑过]

B2层 发表时间: 06-06-06 18:36

回复: NetFog [q70213526]   版主   登录
数据库更新示例:demoUpdate.asp

代码:

<!--#include file="Class.ADO.asp"-->
<%
Set ADO = New Cls_ADO
With ADO
.Db_Type = "AC"
.Db_Path = "./Data/"
.Db_Name = "db1"
.Db_ServerIP = "(local)"
.Db_UserName = "sa"
.Db_UserPWD = "qiuzhi526"
end with
dim vColumn(2),vValue(2)
vTabel = "t"                                              '设置要操作的表

'设置要操作的字段
vColumn(0) = "2"                     
vColumn(1) = "3"
vColumn(2) = "4"
'设置要操作的字段完毕

'设置目标更新值
vValue(0) = "1111"           
vValue(1) = "修改,啊'修改"
vValue(2) = now()
'设置完毕

vCondition = "a=34"                                        '条件,不需要where

ADO.OpenADO                                                '打开连接
ADO.ExeUpdate vTabel,vColumn,vValue,vCondition            '执行操作
ADO.CloseADO                                              '关闭连接
Response.Write "数据库查询次数:--->&nbsp;"&ADO.QueryTotal&"次<br>"
Response.Write "是&nbsp;&nbsp;否&nbsp;&nbsp;出&nbsp;&nbsp;错:--->&nbsp;"&ADO.Errs&"&nbsp;&nbsp;<font color=red size=2>[False

表示未出错]</font>"
Set ADO = Nothing                                          '注销
%>





[此贴被 NetFog(q70213526) 在 06月06日22时00分 编辑过]

B3层 发表时间: 06-06-06 18:38

回复: NetFog [q70213526]   版主   登录
数据删除调用示例

demoDelete.asp

代码:

<!--#include file="Class.ADO.asp"-->
<%
Set ADO = New Cls_ADO
With ADO
.Db_Type = "AC"
.Db_Path = "./Data/"
.Db_Name = "db1"
.Db_ServerIP = "(local)"
.Db_UserName = "sa"
.Db_UserPWD = "qiuzhi526"
end with
condition = "a=5"              '条件
d = "t"                        '表名
ADO.OpenADO                    '打开连接
ADO.ExeDelete d,condition      '执行删除操作
ADO.CloseADO                  '关闭连接
Response.Write "数据库查询次数:--->&nbsp;"&ADO.QueryTotal&"次<br>"
Response.Write "是&nbsp;&nbsp;否&nbsp;&nbsp;出&nbsp;&nbsp;错:--->&nbsp;"&ADO.Errs&"&nbsp;&nbsp;<font color=red size=2>[False表示未出错]</font>"
Set ADO = Nothing              '注销类
%>



B4层 发表时间: 06-06-06 18:42

回复: NetFog [q70213526]   版主   登录
返回特定记录的单一字段时调用示例

demoOneRecord.asp

代码:

<!--#include file="Class.ADO.asp"-->
<%
Set ADO = New Cls_ADO
With ADO
.Db_Type = "AC"
.Db_Path = "./Data/"
.Db_Name = "db1"
.Db_ServerIP = "(local)"
.Db_UserName = "sa"
.Db_UserPWD = "qiuzhi526"
end with
intNum = 2
vTable = "t"
Condition = "a=36"
SQL = "select * from "&vTable&" where "&Condition
ADO.OpenADO                      '打开连接
tmp = ADO.GetOneRecord(intNum,SQL)    '执行操作
ADO.CloseADO                    '关闭连接
Response.Write "数据库查询次数:--->&nbsp;"&ADO.QueryTotal&"次<br>"
Response.Write "是&nbsp;&nbsp;否&nbsp;&nbsp;出&nbsp;&nbsp;错:--->&nbsp;"&ADO.Errs&"&nbsp;&nbsp;<font color=red size=2>[False表示未出错]</font>"
Set ADO = Nothing                '注销

response.write "<br>返&nbsp;&nbsp;回&nbsp;&nbsp;结&nbsp;&nbsp;果:--->&nbsp;"&tmp&"&nbsp;&nbsp;&nbsp;<font color=red size=2>[此例显示出表"""&vTable&"""中的第"""&intNum&"""列中满足"""&Condition&"""条件的值]</font>"
%>



B5层 发表时间: 06-06-06 18:43

回复: NetFog [q70213526]   版主   登录
返回记录集并存入二维数组示例。在数据库存有大量记录时忌用此方法

DemoShowData.asp

代码:

<!--#include file="Class.ADO.asp"-->
<%
Set ADO = New Cls_ADO
With ADO
.Db_Type = "AC"
.Db_Path = "./Data/"
.Db_Name = "db1"
.Db_ServerIP = "(local)"
.Db_UserName = "sa"
.Db_UserPWD = "qiuzhi526"
end with
SQL = "select * from t"
ADO.OpenADO                      '打开连接
tmp = ADO.ExeGetData(SQL)        '执行操作
ADO.CloseADO                    '关闭连接
Response.Write "数据库查询次数:--->&nbsp;"&ADO.QueryTotal&"次<br>"
Response.Write "是&nbsp;&nbsp;否&nbsp;&nbsp;出&nbsp;&nbsp;错:--->&nbsp;"&ADO.Errs&"&nbsp;&nbsp;<font color=red size=2>[False表示未出错]</font><br>"
Set ADO = Nothing                '注销

response.write "<br>返回结果集如下:<br><br>"

For i = 0 to Ubound(tmp,2)
    For k = 0 to Ubound(tmp,1)
    response.write tmp(k,i)&"&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;"
    Next
response.write VBCRLF&"<br>"
Next

response.write "<br><font color=red size=2>PS:通过二维数组输出,大量数据时忌用Cls_ADO的ExeGetData方法</font>"
%>



B6层 发表时间: 06-06-06 18:44

回复: NetFog [q70213526]   版主   登录
丫。。怎么把密码泄露了。

B7层 发表时间: 06-06-06 18:46

回复: NetFog [q70213526]   版主   登录
刚刚朋友提醒。有点小BUG。回头再修改。现在在网吧。不能测试。

B8层 发表时间: 06-06-06 19:20

回复: Aoming [aoming]   版主   登录
强烈支持原创

B9层 发表时间: 06-06-06 21:36

回复: NetFog [q70213526]   版主   登录
BUG已经修正完毕。嘿嘿。。

以后俺写程序在操作数据库时就容易了。呵呵。。爽。。20CN没空间放源码。大家就只好看上面的东东了。。

改天如果有空再发个模版处理类上来。

B10层 发表时间: 06-06-06 22:02

回复: Rootong [tommy_he]   版主   登录
我靠,兄弟,我真TMD崇拜你!

B11层 发表时间: 06-06-13 15:24

回复: NetFog [q70213526]   版主   登录
怎么了?代码封装有问题么??

另有模版处理类,文件操作类,无限级分类操作类。

文件操作类几乎包括了FSO操作中的所有操作过程,当然比直接使用FSO操作简单些了。在以后的开发中,代码封装是有好处的。

B12层 发表时间: 06-06-13 16:04

回复: NetFog [q70213526]   版主   登录
http://www.20cn.net/cgi-bin/club/show.pl?key=HFIPdgyshfvp&cat=tech&forum=code&page=1&position=4729&id=1150443898

模版处理类发“编程破解”版了。

B13层 发表时间: 06-06-16 16:02

回复: toumings3 [toumings3]   论坛用户   登录
基本上看不懂!!!

B14层 发表时间: 06-06-19 11:26

回复: NetFog [q70213526]   版主   登录
无多少难度可言。以后再改进优化。

B15层 发表时间: 06-06-19 16:20

回复: drckness [drckness]   论坛用户   登录
自己写着用的没你的专业。呵呵拿一个类出来批批

<%
'分类操作类,2006-03-07 3:03 PM
Class Cls_Channel

Public Table
Public ID,cname,ParentID,ParentStr,Depth,RootID,ChildNum,Orders,Info,ChildAll
Public Ename,Path
Public DataNum,simage,setting,addtime
Public Template,i,j,selectid,checkedid
Public ListDOM,XMLDOM
Public NewRootID
Public XML

Private Sub Class_Initialize()
'接收参数
Table =cms.myrequest.string("Table")
id =cms.myrequest.number("id")
'初始化xml类
XMLDOM ="Msxml2.FreeThreadedDOMDocument"
Set ListDOM =Server.CreateObject(XMLDOM)

End Sub

Private Sub class_terminate()
If isobject(xml) Then Set xml=Nothing

Set ListDOM=Nothing
End Sub

'==========过程:read();save();update();del();操作时间:2006-03-08 9:28 AM=========================================
Public Sub Read()
cms.data.sql="select top 1 ID,CName,ParentID,ParentStr,Depth,RootID,ChildNum,orders,Info,ChildAll,DataNum,Simage,Setting,Addtime,ename,path from "&Table&" where ID="&ID
Set cms.data.rs=cms.data.execute(cms.data.sql)
if not cms.data.rs.eof then
ID=cms.data.Rs("ID")
CName=cms.data.Rs("CName")
ParentID=cms.data.Rs("ParentID")
ParentStr=cms.data.Rs("ParentStr")
Depth=cms.data.Rs("Depth")
RootID=cms.data.Rs("RootID")
ChildNum=cms.data.Rs("ChildNum")
orders=cms.data.Rs("orders")
Info=cms.data.Rs("Info")
ChildAll=cms.data.Rs("ChildAll")
DataNum=cms.data.Rs("DataNum")
Simage=cms.data.Rs("Simage")
Setting=cms.data.Rs("Setting")
Addtime=cms.data.Rs("Addtime")

ename=cms.data.Rs("ename")
path=cms.data.Rs("path")
end if
cms.data.RS.close
Set cms.data.Rs=nothing
End Sub


Public Function ArraySet(i)
'高级设置产生的数组值
on error resume next
If setting="" or instr(setting,"|")=0 Then
ArraySet=""
End If
Dim ArraySetting
ArraySetting=split(setting,"|")
If i>=0 and i<=ubound(ArraySetting) Then
ArraySet=ArraySetting(i)
Else
ArraySet=""
End If

If Err then ArraySet=""
End Function


Public Function GetChildAllByID(ID,myTable)
table=myTable
If Not isxml() Then MakeXML()
Dim Node

If Not Isobject(XML) Then cloneNode()

Set node=XML.documentElement.selectSingleNode("//*[@id='"&id&"']")

If Node Is Nothing Then
GetChildAllByID="0"
Else
GetChildAllByID=Node.selectSingleNode("@childall").text
End If

Set Node = Nothing
'Set XML = Nothing
End Function

Public Function GetCnameByID(ID)
If Not isxml() Then MakeXML()
Dim Node

If Not Isobject(XML) Then cloneNode()

Set node=XML.documentElement.selectSingleNode("//*[@id='"&id&"']")

If Node Is Nothing Then
GetCnameByID=""
Else
GetCnameByID=Node.selectSingleNode("@cname").text
End If

Set Node = Nothing
'Set XML = Nothing
End Function

Public Function GetChildNodeByID(ID)
If Not isxml() Then MakeXML()
Dim Nodes,Node,str

If Not Isobject(XML) Then cloneNode()

Set nodes=XML.documentElement.selectNodes("//*[@parentid='"&id&"']")

If Nodes Is Nothing Then
str=""
Else
For Each Node In Nodes
Str=Str&","&Node.selectSingleNode("@id").text
Next
End If
Set nodes = Nothing

GetChildNodeByID=mid(Str,2)
End Function


Public Function ChildList(ID,Template)
Dim ListTemplate,LoopBody,Str

Select case Lcase(Template)
case "list"
ListTemplate="<li><a href=""index.asp?id=[ID]"">[cname]</a></li>"
case else
ListTemplate=Template
End Select


If Not isxml() Then MakeXML()
Dim Nodes,Node

If Not Isobject(XML) Then cloneNode()

Set nodes=XML.documentElement.selectNodes("//*[@parentid='"&id&"']")

If Nodes Is Nothing Then
str=""
Else
For Each Node In Nodes
LoopBody=ListTemplate
LoopBody=cms.myReplace(LoopBody,"[id]",node.attributes.getNamedItem("id").text)
LoopBody=cms.myReplace(LoopBody,"[cname]",node.attributes.getNamedItem("cname").text)
Str=Str&LoopBody&vbcrlf
Next
End If
Set nodes = Nothing

ChildList=Str
End Function
'=================list() 从xml取得列表===================================================================


Public Function List()
If Not isxml() Then MakeXML()

Dim TempStr
Dim LoopBody,Str
Dim classID
Dim level:level=100
Select case lcase(Template)
case "list"
TempStr="<tr class=""xcolor[xcolor]"">"&vbcrlf
TempStr=TempStr&"<td>[id]</td>"&vbcrlf
TempStr=TempStr&"<td style=""padding-left:[idepth]px"" class=""Depth[depth]"">[img][cname] ([childnum])</td>"&vbcrlf
TempStr=TempStr&"<td>[dealwith]</td>"&vbcrlf
TempStr=TempStr&"</tr>"&vbcrlf
Case "select"
TempStr="<option value=""[id]"" [selected]>[textIndent][cname]</option>"&vbcrlf

case "selectedlist"
tempstr="<li class=""Depth[depth]""><input type=""checkbox"" name=""classid"" value=""[id]"" [checked]/>[cname]</li>"
level=2
case "channeladd"
tempstr="<li class=""Depth[depth]""><a href=""?action=add&id=[id]"">[cname]</a></li>"
level=2
case "channellist"
tempstr="<li class=""Depth[depth]""><a href=""?action=list&id=[id]"">[cname]</a></li>"
level=2
case else
TempStr=Template
End Select


Dim Node

If Not Isobject(XML) Then cloneNode()

For each node in XML.documentElement.getElementsByTagName("class")
j=j+1

classID =Cint(node.attributes.getNamedItem("id").text)
parentid =Cint(node.attributes.getNamedItem("parentid").text)
cname =node.attributes.getNamedItem("cname").text
Depth =node.attributes.getNamedItem("depth").text
ChildNum =node.attributes.getNamedItem("childnum").text
ChildAll =node.attributes.getNamedItem("childall").text
rootid =node.attributes.getNamedItem("rootid").text
setting =node.attributes.getNamedItem("setting").text

if  cint(depth)=<cint(level) and arrayset(1)="1" then
LoopBody=Replace(TempStr,"[id]",classID)
LoopBody=Replace(LoopBody,"[parentid]",parentid)
LoopBody=Replace(LoopBody,"[cname]",cname)
LoopBody=Replace(LoopBody,"[depth]",depth)
LoopBody=Replace(LoopBody,"[childnum]",ChildNum)
LoopBody=Replace(LoopBody,"[childall]",ChildAll)
LoopBody=Replace(LoopBody,"[idepth]",(depth-1)*20)
LoopBody=Replace(LoopBody,"[img]",flagimg())
LoopBody=Replace(LoopBody,"[xcolor]",xcolor())
LoopBody=Replace(LoopBody,"[dealwith]",dealwith(classID))
LoopBody=Replace(LoopBody,"[textIndent]",textIndent())
LoopBody=Replace(LoopBody,"[selected]",selected(classID))
LoopBody=Replace(LoopBody,"[checked]",checked(classid))
str=str&LoopBody
end if
Next
'Set XML=Nothing

List=str
End Function

Public Function checked(classid)'检查pinpai的分类是否选择
if instr(checkedid,classid)<>0 then
checked="checked"
else
checked=""
end if
End Function
Private Function flagimg()
If ChildNum=0 Then
flagimg="<img src="""&cms.skin&"/system/Rminus.gif"" />"
Else
flagimg="<img src="""&cms.skin&"/system/Rplus.gif"" />"
End If
End Function

Private Function xcolor()
if j mod 2 =1 Then
xcolor=1
else
xcolor=0
End if
End Function

Private Function dealwith(id)
dealwith="<a href=""?action=add&id="&id&"&table="&table&""">添加子类</a> ┇"&vbcrlf
dealwith=dealwith&"<a href=""?action=edit&id="&id&"&table="&table&""">基本设置</a> ┇"&vbcrlf
dealwith=dealwith&"<a href=""?action=more&id="&id&"&table="&table&""">高级设置</a> ┇"&vbcrlf
dealwith=dealwith&"<a href=""?action=orders&id="&id&"&table="&table&""">排序</a> ┇"&vbcrlf
dealwith=dealwith&"<a href=""?action=del&id="&id&"&table="&table&""" "&cms.msg.confirm("确定要删除?")&">删除</a>"&vbcrlf
End Function

Private Function textIndent()
textIndent=""
If depth>1 Then
for i=1 to depth-1
textIndent=textIndent&"&nbsp;&nbsp;"
Next
textIndent=textIndent&"┣"
end if
End Function

Public Function selected(classid)
if instr(checkedid,classid)<>0 then
selected="selected"
else
selected=""
end if

End Function
'=============================分类的xml=============================================================
Public Sub MakeXML()

ListDOM.appendChild(ListDOM.createProcessingInstruction("xml","version=""1.0"" encoding=""gb2312"""))
ListDOM.appendChild(ListDOM.createElement("classList"))

ListDOM.documentElement.attributes.setNamedItem(ListDOM.createNode(2,"Product","")).text="Hankx"
ListDOM.documentElement.attributes.setNamedItem(ListDOM.createNode(2,"Version","")).text="cms.config.cmsversion"
ListDOM.documentElement.attributes.setNamedItem(ListDOM.createNode(2,"Copyright","")).text="Hankx"
ListDOM.documentElement.attributes.setNamedItem(ListDOM.createNode(2,"classid","")).text=0
'生成节点
LoadChild ListDOM.documentElement,0
'存储xml数据
Application.Lock
Set Application(cms.config.cachename&"_"&Table&"_xmllist")= ListDOM.cloneNode(True)
Application(cms.config.cachename&"_"&Table&"_xmlcache")=true
Application.UnLock
End Sub

'递归过程,生成XML节点
Private Sub LoadChild(Node,ParentID)
Dim ChildNode,rs
cms.data.Sql="select id,cname,parentid,depth,rootid,childnum,childall,rootid,setting from "&Table&" where  ParentID="& ParentID &" Order By orders asc"
Set Rs=cms.data.Execute(cms.data.Sql)
Do While Not Rs.EOF
Set ChildNode=ListDOM.createNode(1,"class","")
For i = 0 To Rs.Fields.Count-1
ChildNode.attributes.setNamedItem(ListDOM.createNode(2,Rs(i).name,"")).text = Rs(i)&""
Next
Node.appendChild(ChildNode)
LoadChild ChildNode,Rs(0)
Rs.MoveNext
Loop
Rs.Close : Set Rs = Nothing
End Sub

Public Sub ShowXML()
If Not isxml() Then MakeXML()

If Not Isobject(XML) Then cloneNode()

Response.clear()
Response.CharSet="gb2312" 
Response.ContentType="text/xml"
Response.Write "<?xml version=""1.0"" encoding=""gb2312""?>"&vbNewLine
Response.Write XML.documentElement.XML
Response.End()
'Set XML=nothing
End Sub

Public Sub DELXML()
Application.Lock
set Application(cms.config.cachename&"_"&Table&"_xmllist")=nothing
Application(cms.config.cachename&"_"&Table&"_xmlcache")=false
Application.UnLock
End Sub

Public Function isXML()
isxml=Application(cms.config.cachename&"_"&Table&"_xmlcache")
End Function
'=============================分类的xml=============================================================
Public Function Navbar()

If Not isxml() Then MakeXML()
Dim TempStr
Dim LoopBody,Str
Select Case Lcase(template)
case "navbar"
TempStr=" → <a href=""?id=[id]"">[cname]</a>"
case else
TempStr=template
End Select

If cname="" or ParentID="" or Parentstr="" Then call Read()
Dim ParentIDs
ParentIDs=split(Parentstr,",")

Dim Node

If Not Isobject(XML) Then cloneNode()

For i=0 TO ubound(ParentIDs)
Set node=XML.documentElement.selectSingleNode("//*[@id='"&ParentIDs(i)&"']")
If Node Is Nothing Then Exit For
LoopBody=Replace(TempStr,"[id]",ParentIDs(i))
LoopBody=Replace(LoopBody,"[cname]",Node.selectSingleNode("@cname").text)
str=str&LoopBody
Next
'Set XML=Nothing
Navbar=str
End Function

Public Function FilePath()
'on error resume next
Dim str
str=ArraySet(10)

str=Lcase(str)
str=Replace(str,"[id]",id)
str=Replace(str,"[idpath]",Replace(parentstr,",","/"))
str=Replace(str,"[ename]",ename)
str=Replace(str,"[path]",path)
str=Replace(str,"[yy]",Year(Now()))
str=Replace(str,"[mm]",Month(Now()))
str=Replace(str,"[dd]",Day(Now()))

str=Replace(str,"///","/")
str=Replace(str,"//","/")

FilePath=str


End Function

Public Sub CloneNode()
Set XML=Application(cms.config.cachename&"_"&Table&"_xmllist").cloneNode(True)
XML.validateOnParse = False
XML.resolveExternals = False
End Sub
End Class
%>++++++++++++++++++++++++++++++
下面是我们这个项目自己写的类。多吧哈哈哈
++++++++++++++++++++++++++++++


B16层 发表时间: 06-06-20 17:01

回复: NetFog [q70213526]   版主   登录
XMLDOM没怎么用过。。

对了。你的分类是无限级的么????

B17层 发表时间: 06-06-20 20:48

回复: NetFog [q70213526]   版主   登录
我的无限级分类和你的不一样。。

查询数据库一次,将所有分类读入数组中,其中有个字段用货币类型,值类型10000000001之类的,你的没有仔细看,在网吧不太方便。原理不一样吧。我的所谓无限级分类其实也不是真正意义上的无限级分类,只是可以达到100W个分类罢了。受货币类型字段最大长度的影响。

B18层 发表时间: 06-06-20 20:56

回复: NetFog [q70213526]   版主   登录
兄弟你的如果能再规范点就容易看明白了。。呵呵。。加之我对XML之类的东东不懂。。有时间再研究研究。所以看得有点迷忽迷忽了。

B19层 发表时间: 06-06-20 21:10

回复: nafeir [nafeir]   论坛用户   登录
NNDX。。看得晕忽忽的。。。。偶本来/\想说粗话滴。。因为偶滴淑女形像就这么没了。。。
/\过看到了这个偶根本豆看不明白的东东。。实在系有点旺火。。忽忽。。。

B20层 发表时间: 06-06-25 10:26

回复: NetFog [q70213526]   版主   登录


原来是个MM啊???哈哈哈。。无人讨论,俺到其他论坛玩去。

B21层 发表时间: 06-06-25 12:09

回复: XinSoft [xinsoft]   论坛用户   登录
真是精华帖子啊:)

我先支持一下,有时间了再慢慢和楼主探讨这方面的问题。



B22层 发表时间: 06-07-10 11:43

回复: NetFog [q70213526]   版主   登录
辛总..

你太抬举我了..我这东西是小儿科了。

B23层 发表时间: 06-07-10 14:25

论坛: 网站建设

20CN网络安全小组版权所有
Copyright © 2000-2010 20CN Security Group. All Rights Reserved.
论坛程序编写:NetDemon

粤ICP备05087286号