TDB 数据库管理类

<% Class TDB private FConn,FConnStr,FSQL,FRS 'RS用于临时数据集 Dim SQL_INJECT,MSG_DB_ERR,MSG_INJECT_ERR '初始化还不连接，需要时再连接 sub Class_Initialize SQL_INJECT = "select|update|insert|delete|exec|truncate|declare" MSG_DB_ERR = Replace("{0}<br/>数据库连接错误，请重新安装！<a href=""{1}"">进入安装</a>", _ "{1}",sys.toDir(sys.getSession(SESS_URL_ROOT)) & FILE_INSTALL) MSG_INJECT_ERR = "数据中包含不允许的字符：{0}" FSQL = "" set FConn = sys.getObj(SO_CONN) end sub sub class_Terminate ' 自动关闭连接 if connected Then FConn.Close set FConn = nothing end sub private sub open() On Error Resume next If Not connected Then Fconn.open FConnStr If Err.number <> 0 Then sys.print Replace(MSG_DB_ERR,"{0}",Err.description) sys.halt End if end Sub '--------------- property begin -------------------- public Property let ConnStr(ByVal value) FConnStr = value End property public Property Get connected() connected = (FConn.state = 1) End property public property get conn() If Not connected Then open '按需连接，页面生存周期 set conn = FConn '传的是地址 end property public property get sql() sql = FSQL end property public property let sql(byval value) FSQL = value end Property '------------ property end --------------------- Private Sub checkErr() If Err.number <> 0 Then sys.print Err.description & "<br />" & FSQL sys.halt End If On Error goto 0 End Sub '执行SQL public function exec() On Error Resume Next set exec = conn.execute(FSQL) Call checkErr FSQL = "" end function public function execute(aSQL) FSQL = aSQL set execute = exec() end function '返回Recordset对象 public function getRS(openmodel,lockmodel) Dim rs set rs = sys.getObj(SO_REC) On Error Resume Next rs.open FSQL,conn,openmodel,lockmodel Call checkErr FSQL = "" Set getRS = rs end function '查询数据库取值 Public Function getValue() Set FRS = exec() If FRS.eof Then getValue = "" Else getValue = FRS(0) End If FSQL = "" FRS.close End Function '-----------------------数据验证---------------------------- ' 日期判断 Public Function qdate(aDate) If IsDate(aDate) Then qdate = "#" & aDate & "#" Else qdate = "" End if End Function ' 数字判断 Public Function qnum(aNum) If IsNumeric(aNum) Then qnum = CStr(aNum) Else qnum = "" End If End function '单引号替换函数，用于SQL Public Function qstr(aStr) If IsNull(aStr) Then qstr = "''" else qstr = Trim(Replace(aStr,"'","''")) qstr = "'" & qstr & "'" End If End Function '双引号替换函数，用于CSV Public Function qstring(aStr) If IsNull(aStr) Then qstring = Chr(34) & Chr(34) else qstring = Trim(Replace(aStr,Chr(34),Chr(34)&Chr(34))) qstring = Chr(34) & qstring & Chr(34) End If End Function Public Function checkInject(value) Dim val,arrInject,i val = LCase(value) arrInject = Split(SQL_INJECT,"|") For i = LBound(arrInject) To UBound(arrInject) If InStr(val,arrInject(i)) > 0 Then sys.goBack Replace(MSG_INJECT_ERR,"{0}",arrInject(i)) Exit function End if Next checkInject = value End Function '-------------------------------------------------------------- '事务处理 Public Sub trans(op) Select case op Case 0 : FConn.beginTrans Case 1 : FConn.CommitTrans Case 2 : FConn.RollbackTrans End Select End sub '下拉列表 Public Sub printOptions(aSQL,value) dim sOption,selected sOption = "<option value=""{0}"" {1}>{2}</option>" If IsNull(value) Then value = "" Set FRS = execute(aSQL) do while not FRS.eof selected = "" If cstr(FRS(0)) = CStr(value) Then selected = "selected" sys.print Replace(Replace(Replace(sOption,"{0}",FRS(0)),"{1}",selected),"{2}",FRS(1)) FRS.movenext Loop FRS.close End Sub ' 对象释放 public sub closeObj(ByRef value) if isobject(value) then If value.state = 1 Then value.close set value = nothing end if end sub public sub closeObjs(ByRef value1,ByRef value2) closeObj value1 closeObj value2 end sub 'CSV数据库连接 Public Function csvConn(aPath) '' response.codepage = 936 '' 处理的页面加这句乱码消失，其他的编码均不变，都为utf-8 dim connstr connstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & aPath _ & ";Extended Properties='text;FMT=Delimited'" set csvConn = sys.getObj(SO_CONN) csvConn.open connstr End function '数据导出格式 Public Sub export(aExt,aFilename) 'Response.Buffer = True Response.AddHeader "Content-Disposition", "attachment;filename=" & aFilename & "." & aExt Response.contenttype = "text/" & aExt End Sub Private Function dataLine(ByRef aRS,ByRef aFields) Dim i,keys keys = aFields.keys For i = 0 To aFields.count - 1 keys(i) = qstring(aRS(keys(i))) Next dataLine = Join(keys,",") End Function Public Sub exportCSV(ByRef aRS,ByRef aFields) aRS.movefirst sys.print Join(aFields.items,",") ' header If aRS.eof Then Exit Sub While Not aRS.eof sys.print vbCrLf & dataLine(aRS,aFields) aRS.movenext wend End sub end Class %>