论坛: 网站建设 标题: 发布一个刚刚完成的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号