% 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="
SourceConn = Jet_Conn_Partial AppPath() strDBFileName DestConn = Jet_Conn_Partial AppPath() "Temp" strDBFileName Set oFSO = Server.CreateObject("Scripting.FileSystemObject") Set oJetEngine = Server.CreateObject("JRO.JetEngine")
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
