% 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
