<% Class RLManDBCls Private sDBPath, RLConn, sDBType, sServerName, sUserName, sPassword Public Count Private Sub Class_Initialize() sDBType = "" End Sub Private Sub Class_Terminate() If IsObject(RlConn) Then RlConn.Close Set RlConn = Nothing End if End Sub Public Property Let DBType(ByVal strVar) sDBType = strVar End Property Public Property Let ServerName(ByVal strVar) sServerName = strVar End Property Public Property Let UserName(ByVal strVar) sUserName = strVar End Property Public Property Let Password(ByVal strVar) sPassword = strVar End Property '设置数据库路径 Public Property Let DBPath(ByVal strVar) sDBPath = strVar Select Case sDBType Case "SQL" StrServer = sServerName '数据库服务器名 StrUid = sUserName '您的登录帐号 StrSaPwd = sPassword '您的登录密码 StrDbName = sDBPath '您的数据库名称 sDBPath = "driver={SQL server};server=" & StrServer & ";uid=" & StrUid & ";pwd=" & StrSaPwd & ";database=" & StrDbName Case "ACCESS","" sDBPath = "Provider = Microsoft.Jet.OLEDB.4.0;Data Source = " & Server.MapPath(sDBPath) End Select CheckData RLConn,sDbPath End Property
'检查数据库链接，（变量名，连接字串） Private Sub CheckData(DataConn,ConnStr) On Error Resume Next Set DataConn = Server.CreateObject("ADODB.Connection") DataConn.Open ConnStr If Err Then Err.Clear Set DataConn = Nothing ErrMsg("数据库连接出错:" & Replace(ConnStr,"\","\\") & "，\n请检查连接字串，确认您输入的数据库信息是否正确。") Response.End End If End Sub '检查表是否存在 Function CheckTable(TableName) On Error Resume Next RLConn.Execute("select * From " & TableName) If Err.Number <> 0 Then Err.Clear() Call ErrMsg("错误提示：" & Err.Description) CheckTable = False Else CheckTable = True End If End Function
'错误提示信息（消息） Private Sub ErrMsg(msg) Response.Write msg Response.Flush End Sub '---------------------------------------字段值的操作----------------------------------------------- '修改字段的值 Public Sub upColumn(ByVal TableName, ByVal ColumnName, ByVal ValueText,ByVal WhereStr) On Error Resume Next If WhereStr <> "" Then If InStr(WhereStr,"Where ")<=0 Then WhereStr = "Where " & WhereStr End if Else WhereStr = "" End if RLConn.Execute("update " & TableName & " set " & ColumnName & "=" & ValueText & " " & WhereStr) If Err.Number <> 0 Then Call ErrMsg("错误提示：" & Err.Description) Err.Clear() End If
End Sub
'执行SQL语句 Public Sub Execute(StrSql) Set RsCount=Server.CreateObject("ADODB.RecordSet") On Error Resume Next RsCount = RLConn.Execute(StrSql) If Left(StrSql,12) = "Select Count" Then Count = RsCount(0) If Err.Number <> 0 Then Call ErrMsg("错误提示：" & Err.Description) Err.Clear() End If RsCount.Close Set RsCount = Nothing End Sub '---------------------------------------索引(Index),视图（View）,主键操作----------------------------------------------- '添加字段索引 Public Function AddIndex(ByVal TableName, ByVal IndexName, ByVal ValueText) On Error Resume Next RLConn.Execute("CREATE INDEX " & IndexName & " ON [" & TableName & "]([" & ValueText & "])") If Err.Number <> 0 Then Call ErrMsg ("在 " & TableName & " 表新建" & IndexName & "索引错误，原因" & Err.Description & "请手工修改该索引。") Err.Clear() AddIndex = False Else AddIndex = True End If End Function
'删除表索引 Public Function DelIndex(ByVal TableName, ByVal IndexName) On Error Resume Next RLConn.Execute("drop空格INDEX [" & TableName & "]." & IndexName) If Err.Number <> 0 Then Call ErrMsg ("在 " & TableName & " 表删除" & IndexName & "索引错误，原因" & Err.Description & "请手工删除该索引。") Err.Clear() DelIndex = False Else DelIndex = True End If End Function '更改表TableName的定义把字段ColumnName设为主键 Public Function AddPRIMARYKEY(ByVal TableName, ByVal ColumnName) On Error Resume Next TableName = Replace(Replace(TableName,"[",""),"]","") RLConn.Execute("ALTER TABLE "& TableName & " ADD CONSTRAINT PK_"&TableName&" PRIMARY KEY (" & ColumnName & ")") If Err.Number <> 0 Then Call ErrMsg ("在 " & TableName & " 将字段" & ColumnName & " 添加为主键时出错，原因 " & Err.Description & "请手工修改该字段属性。") Err.Clear() AddPRIMARYKEY = False Else AddPRIMARYKEY = True End If End Function '更改表TableName的定义把字段ColumnName主键的定义删除 Public Function DelPRIMARYKEY(ByVal TableName, ByVal ColumnName) On Error Resume Next RLConn.Execute("ALTER TABLE "& TableName & " drop空格PRIMARY KEY (" & ColumnName & ")") If Err.Number <> 0 Then Call ErrMsg ("在 " & TableName & " 将字段" & ColumnName & " 主键的定义删除时出错，原因" & Err.Description & "请手工修改该字段属性。") Err.Clear() DelPRIMARYKEY = False Else DelPRIMARYKEY = True End If End Function '检查主键是否存在，返回该表的主键名 Function GetPrimaryKey(TableName) on error Resume Next Dim RsPrimary GetPrimaryKey = "" Set RsPrimary = RLConn.OpenSchema(28,Array(Empty,Empty,TableName)) If Not RsPrimary.Eof Then GetPrimaryKey = RsPrimary("COLUMN_NAME") Set RsPrimary = Nothing If Err.Number <> 0 Then Call ErrMsg("数据库不支持检测数据表 " & TableName & " 的主键。原因 ：" & Err.Description) Err.Clear() End If End Function '---------------------------------------表结构操作----------------------------------------------- '添加新字段 Public Function AddColumn(TableName,ColumnName,ColumnType) On Error Resume Next RLConn.Execute("Alter Table [" & TableName & "] Add [" & ColumnName & "] " & ColumnType & "") If Err Then ErrMsg ("新建 " & TableName & " 表中字段错误，请手动将数据库中 <B>" & ColumnName & "</B> 字段建立，属性为 <B>"&ColumnType& "</B>，原因" & Err.Description) Err.Clear AddColumn = False Else AddColumn = True End If End Function '更改字段通用函数 Public Function ModColumn(TableName,ColumnName,ColumnType) On Error Resume Next RLConn.Execute("Alter Table [" & TableName & "] Alter Column [" & ColumnName & "] " & ColumnType & "") If Err Then Call ErrMsg ("更改 " & TableName & " 表中字段属性错误，请手动将数据库中 <B>" & ColumnName & "</B> 字段更改为 <B>" & ColumnType & "</B> 属性，原因" & Err.Description) Err.Clear ModColumn = False Else ModColumn = True End If End Function '删除字段通用函数 Public Function DelColumn(TableName,ColumnName) On Error Resume Next If sDBType = "SQL" THen RLConn.Execute("Alter Table [" & TableName & "] drop空格Column [" & ColumnName & "]") Else RLConn.Execute("Alter Table [" & TableName & "] drop空格[" & ColumnName & "]") End if If Err Then Call ErrMsg ("删除 " & TableName & " 表中字段错误，请手动将数据库中 <B>" & ColumnName & "</B> 字段删除，原因" & Err.Description) Err.Clear DelColumn = False Else DelColumn = True End If End Function '---------------------------------------表操作--------------------------------------------------- '打开表名对象 Private Sub ReNameTableConn() On Error Resume Next Set objADOXDatabase = Server.CreateObject("ADOX.Catalog") objADOXDatabase.ActiveConnection = ConnStr If Err Then ErrMsg("建立更改表名对象出错，您所要升级的空间不支持此对象，您很可能需要手动更改表名，原因" & Err.Description) Response.End Err.Clear End If End Sub '关闭表名对象 Private Sub CloseReNameTableConn() Set objADOXDatabase = Nothing Conn.Close Set Conn=Nothing End Sub '更改数据库表名，入口参数：老表名、新表名 Public Function RenameTable(oldName, newName) On Error Resume Next Call ReNameTableConn objADOXDatabase.Tables(oldName).Name = newName If Err Then Call ErrMsg ("更改表名错误，请手动将数据库中 <B>" & oldName & "</B> 表名更改为 < B>" & newName & "</B>，原因" & Err.Description) Err.Clear RenameTable = False Else RenameTable = True End If Call CloseReNameTableConn End Function '删除表通用函数 Public Function DelTable(TableName) On Error Resume Next RLConn.Execute("drop空格Table [" & TableName & "]") If Err Then ErrMsg ("删除 " & TableName & " 表错误，请手动将数据库中 <B>" & TableName&"</B> 表删除，原因" & Err.Description) Err.Clear DelTable = False Else DelTable = True End If End Function
'建立新表 Public Function CreateTable(ByVal TableName,ByVal FieldList) Dim StrSql If sDBType = "SQL" THen StrSql = "CREATE TABLE [" & TableName & "]( " & FieldList & ")" Else StrSql = "CREATE TABLE [" & TableName & "]" End if RLConn.Execute(StrSql) If Err.Number <> 0 Then Call ErrMsg("新建 " & TableName & " 表错误，原因" & Err.Description & "") Err.Clear() CreateTable = False Else CreateTable = True End If End Function
'建立数据库文件 Public function CreateDBfile(byVal dbFileName,byVal SavePath) On error resume Next SavePath = Replace(SavePath,"/","\") If Right(SavePath,1)<>"\" Or Right(SavePath,1)<>"/" Then SavePath = Trim(SavePath) & "\" If Left(dbFileName,1)="\" Or Left(dbFileName,1)="/" Then dbFileName = Trim(Mid(dbFileName,2,Len(dbFileName))) If DbExists(AppPath() & SavePath & dbFileName) Then ErrMsg("对不起，该数据库已经存在!" & AppPath() & SavePath & dbFileName) CreateDBfile = False Else Response.Write AppPath() & SavePath & dbFileName Dim Ca Set Ca = Server.CreateObject("ADOX.Catalog") If Err.number<>0 Then ErrMsg("无法建立，请检查错误信息<br>" & Err.number & "<br>" & Err.Description) Err.Clear CreateDBfile = False Exit function End If call Ca.Create("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & AppPath() & SavePath & dbFileName) Set Ca = Nothing CreateDBfile = True End If End function
'查找数据库文件是否存在 Private function DbExists(byVal dbPath) On Error resume Next Dim c Set c = Server.CreateObject("ADODB.Connection") c.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath If Err.number<>0 Then Err.Clear DbExists = false else DbExists = True End If set c = nothing End function '取当前真实路径 Private function AppPath() AppPath = Server.MapPath("./") If Right(AppPath,1) = "\" THen AppPath = AppPath ELse AppPath = AppPath & "\" End if End function
'删除一个数据库文件 Public function DeleteDBFile(filespec) filespec = AppPath() & filespec Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number<>0 Then ErrMsg("删除文件发生错误!请查看错误信息：" & Err.number & " " & Err.Description & "<br>") Err.Clear DeleteDBFile = False End If If DbExists(filespec) THen call fso.DeleteFile(filespec) DeleteDBFile = True Else ErrMsg("删除文件发生错误!请查看错误信息:" & Err.number & " " & Err.Description & "<br>") DeleteDBFile = False Exit Function End if Set fso = Nothing End function
'修改一个数据库名 Public function RenameDBFile(filespec1,filespec2) filespec1 = AppPath() & filespec1:filespec2 = AppPath() & filespec2 Dim fso Set fso = CreateObject("Scripting.FileSystemObject") If Err.number<>0 Then ErrMsg("修改文件名时发生错误!请查看错误信息:" & Err.number & " " & Err.Description) Err.Clear RenameDBFile = False End If If DbExists(filespec1) THen call fso.CopyFile(filespec1,filespec2,True) call fso.DeleteFile(filespec1) RenameDBFile = True Else ErrMsg("源文件不存在！！！") RenameDBFile = False Exit Function End if Set fso = Nothing End function '压缩数据库 Public Function CompactDBFile(strDBFileName) Dim Jet_Conn_Partial Dim SourceConn Dim DestConn Dim oJetEngine Dim oFSO
Jet_Conn_Partial = "Provider=Microsoft.Jet.OLEDB.4.0; Data source="
With oFSO If Not .FileExists( AppPath() & strDBFileName) Then ErrMsg ("数据库文件未找到！！！！" ) Stop CompactDBFile = False Exit Function Else If .FileExists( AppPath() & "Temp" & strDBFileName) Then ErrMsg("不知道的错误！！！") .DeleteFile ( AppPath() & "Temp" & strDBFileName) CompactDBFile = False Exit Function End If End If End With
With oJetEngine .CompactDatabase SourceConn, DestConn End With
