inc_engine.asp

可在线管理ACCESS数据库,可新建,修改,建表等如同本地操作数据库

	'# Function that manages transactions. Have to start a transaction
	'# on the main Connection object, not on its descendands
	Public Sub BeginTransaction()
		If IsOpen() Then call JetConnection_.BeginTrans()
	End Sub

	Public Sub CommitTransaction()
		If IsOpen() Then call JetConnection_.CommitTrans()
	End Sub
	
	Public Sub RollbackTransaction()
		If IsOpen() Then call JetConnection_.RollbackTrans()
	End Sub
	
	'######################################################## 
	'# Just executes a single SQL statement on a connection
	'# This was made to keep transactions working
	Public Function Execute(strSQL)
		if IsOpen() Then call JetConnection_.Execute(strSQL, adExecuteNoRecords)

		Execute = True
	End Function
	
	'---------------------------
	'protected and private


	Private Tables_
	Private Relations_
	Private Views_
	Private Procedures_
	Private DatabasePath_
	Private DatabasePassword_
	Private JetConnection_
	Private LastError_
	Private EngineVersion_
	Private UseADOX_
	
	Private Function GetFilenameFromDSN(dsnName, pwd)
		dim dsn, ret, i
		ret = ""
		set dsn = Server.CreateObject("ADODB.Connection")

		if not DBAE_DEBUG then On Error Resume Next
		call dsn.Open("DSN=" & dsnName, "Admin", pwd)
		if not IsError then
			ret = dsn.Properties("Current Catalog").Value
			if Len(ret) > 0 then
				if Right(ret, 4) <> ".mdb" then ret = ret & ".mdb"
			else
				ret = dsn.Properties("Extended Properties").Value
				i = InStr(1, ret, "DBQ=", vbTextCompare)
				if i > 0 then
					ret = Left(ret, i+4)
					i = InStr(1, ret, ";")
					ret = Left(ret, i-1)
				else
					ret = ""
				end if
			end if
			dsn.Close
		end if
		set dsn = Nothing
		GetFilenameFromDSN = ret
	End Function

End Class
' END CLASS DEFINITION DBAdmin


'///////////////////////////////////////////////////////////////
'// Holds any information of the table. When this class first created it contains only Name, but when any other property is accessed, it calls Reload to load all other information from database
'//
Class DBATable

	'constructor
	Private Sub Class_Initialize
		Set Fields_		= Server.CreateObject("Scripting.Dictionary")
		Set Indexes_	= Server.CreateObject("Scripting.Dictionary")
		Fields_.Add ".uninitialized", null
		Indexes_.Add ".uninitialized", null

		Name_			= ""
		Description_	= ""
		DateCreated_	= null
		DateModified_	= null
		TableType_		= "TABLE"
		Set Parent_		= Nothing
	End Sub
	
	'destructor
	Private Sub Class_Terminate
		Fields_.RemoveAll
		Indexes_.RemoveAll
		Set Fields_		= Nothing
		Set Indexes_	= Nothing
	End Sub



	'######################################################## 
	'# Parent object - DBAdmin
	Public Property Set Parent(v)
		if IsObject(v) then Set Parent_ = v
	End Property
	
	Public Property Get Parent
		if IsObject(Parent_) then Set Parent = Parent_ else Set Parent = Nothing
	End Property  

	'######################################################## 
	'# Name of the table
	Public Property Let Name(v)
		if Len(Name_) = 0 then 
			'first time initializing, just assign
			Name_ = CStr(v)
		ElseIf Len(CStr(v)) > 0 and CStr(v) <> Name_ Then
			'we are trying to rename the table
			dim xcat
			set xcat = Server.CreateObject("ADOX.Catalog")
			if not xcat Is Nothing Then
				xcat.ActiveConnection = Parent_.JetConnection
				xcat.Tables(Name_).Name = v
				if not Parent_.IsError Then Name_ = CStr(v)
				set xcat = Nothing
			Else
				Parent_.LastError = "ADOX is not available. Operation cancelled"
			End If
		End If
	End Property    
	
	Public Property Get Name
		Name = Name_
	End Property  
	
	Public Property Get TableType
		TableType = TableType_
	End Property
	
	Public Property Let TableType(v)
		TableType_ = v
	End Property
	
	Public Property Get IsSystem
		if TableType = "SYSTEM TABLE" or TableType = "ACCESS TABLE" Then
			IsSystem = True
		Else
			IsSystem = False
		End If
	End Property
	
	Public Property Get IsLinked
		If TableType = "LINK" or TableType = "ALIAS" or TableType = "PASS-THROUGH" Then 
			IsLinked = True
		Else
			IsLinked = False
		End If
	End Property

	'######################################################## 
	'# Fields collection
	Public Property Get Fields
		if not IsInitialized then Exit Property
		
		if Fields_.Exists(".uninitialized") then
			dim rec, f, xCat, bNoADOX
			Fields_.RemoveAll
			
			if not DBAE_DEBUG then On Error Resume Next
			set rec = Parent_.JetConnection.OpenSchema(adSchemaColumns, Array(empty,empty, Name_))
			set xCat = Server.CreateObject("ADOX.Catalog")
			if (IsEmpty(xCat) or xCat Is Nothing or not Parent_.UseADOX) Then
				Err.Clear
				set xCat = Parent_.JetConnection.Execute(Name_)
				bNoADOX = True
			else
				set xCat.ActiveConnection = Parent_.JetConnection
				bNoADOX = False
			End If
			If Parent_.IsError then exit Property
			do while not rec.EOF
				set f = new DBAField
				with f
					.Name = rec("COLUMN_NAME").Value
					if bNoADOX Then .FieldType = rec("DATA_TYPE").Value else .FieldType = xCat.Tables(Name_).Columns(.Name).Type
					.MaxLength = rec("CHARACTER_MAXIMUM_LENGTH").Value
					.DefaultValue = rec("COLUMN_DEFAULT").Value
					.IsNullable = rec("IS_NULLABLE").Value
					.Ordinal = rec("ORDINAL_POSITION").Value
					.Description = rec("DESCRIPTION").Value
					if bNoADOX Then
						.IsAutonumber = xCat(.Name).Properties("ISAUTOINCREMENT").Value
						.Compressed = False
						.AllowZeroLength = False
					Else
						.IsAutonumber = xCat.Tables(Name_).Columns(.Name).Properties("Autoincrement").Value
						.Compressed = xCat.Tables(Name_).Columns(.Name).Properties("Jet OLEDB:Compressed UNICODE Strings").Value
						.AllowZeroLength = xCat.Tables(Name_).Columns(.Name).Properties("Jet OLEDB:Allow Zero Length").Value
					End If
					Set .Parent = Me
				end with
				Set Fields_.Item(f.Name) = f

				rec.MoveNext
			loop
			rec.Close
			if bNoADOX Then xCat.Close
			set rec = nothing
			set xCat = Nothing
		end if
		
		Set Fields = Fields_
	End Property  

	'######################################################## 
	'# Indexes collection
	Public Property Get Indexes
		if not IsInitialized then Exit Property
		
		if Indexes_.Exists(".uninitialized") then
			dim rec, indx
			Indexes_.RemoveAll
			
			if not DBAE_DEBUG then On Error Resume Next
			set rec = Parent_.JetConnection.OpenSchema(adSchemaIndexes,Array(empty,empty,empty,empty, Name_))
			If Parent_.IsError then Exit Property
			do while not rec.EOF
				set indx = new DBAIndex
				with indx
					.Ordinal = rec("ORDINAL_POSITION").Value
					.Name = rec("INDEX_NAME").Value
					.TargetField = rec("COLUMN_NAME").Value
					.IsUnique = rec("UNIQUE").Value
					.IsPrimary = rec("PRIMARY_KEY").Value
					.SortOrder = rec("COLLATION").Value
					Set .Parent = Me
				end with
				Set Indexes_.Item(indx.Name & "." & indx.TargetField) = indx
				
				rec.MoveNext
			loop
			rec.Close
			set rec = nothing
		end if
		
		Set Indexes = Indexes_
	End Property  

	'######################################################## 
	'# Contains SQL statment for creating this table, including indexes, but not including relationships
	Public Property Get SQL
		dim strSQL, strTemp, item
		strSQL = "CREATE TABLE [" & Name_ & "]"
		
		'get fields definitions
		strTemp = ""
		for each item in Fields.Items
			strTemp = strTemp & item.SQL & ", "
		next
		if Len(strTemp) > 0 then 
			strTemp = Left(strTemp, Len(strTemp) - 2)
			strSQL = strSQL & "(" & strTemp & ")"
		end if
		strSQL = strSQL & ";" & vbCrLf & vbCrLf
		
		'get all indexes
		strTemp = ""
		for each item in Indexes.Items
			if InStr(1, strTemp, item.Name, vbTextCompare) <= 0 and not item.IsForeignKey then
				strSQL = strSQL & item.SQL & ";" & vbCrLf
				strTemp = strTemp & item.Name & "."
			end if
		next
		
		SQL = strSQL
	End Property  

	'######################################################## 
	'# Read-only value of description of the table
	Public Property Get Description
		Description = Description_
	End Property  

	Public Property Let Description(v)
		if Len(Description_) = 0 and not IsNull(v) then Description_ = CStr(v)
	End Property  

	'######################################################## 
	'# Date when the table was created. Read-only
	Public Property Get DateCreated
		DateCreated = DateCreated_
	End Property  

	Public Property Let DateCreated(v)
		if IsNull(DateCreated_) and not IsNull(v) then DateCreated_ = CDate(v)
	End Property  

	'######################################################## 
	'# Date when the table was last modified. Read-only
	Public Property Get DateModified
		DateModified = DateModified_
	End Property 
	 
	Public Property Let DateModified(v)
		if IsNull(DateModified_) and not IsNull(v) then DateModified_ = CDate(v)
	End Property  

	'######################################################## 
	'# Creates and appends a new field
	Public Function CreateField(ByRef NewFld, Indexed)
		CreateField = False
		if not DBAE_DEBUG then On Error Resume Next
		
		dim xCat, fld, isUnique, sSQL
		set xCat = Server.CreateObject("ADOX.Catalog")
		If IsEmpty(xCat) or xCat Is Nothing or not Parent_.UseADOX Then
			'ADOX is not available, then let's create the field with pure SQL
			sSQL = "ALTER TABLE [" & Name_ & "] ADD COLUMN " & NewFld.SQL
			call Parent_.Execute(sSQL)
		Else
			'whoala! ADOX with us, easy work :)
			set xCat.ActiveConnection = Parent_.JetConnection
			set fld = Server.CreateObject("ADOX.Column")
			set fld.ParentCatalog = xCat
			fld.Name = NewFld.Name
			if NewFld.MaxLength > 0 then fld.DefinedSize = NewFld.MaxLength
			fld.Type = NewFld.FieldType
			fld.Properties("Nullable").Value = NewFld.IsNullable
			if NewFld.IsAutonumber then fld.Properties("Autoincrement").Value = True
			fld.Properties("Jet OLEDB:Compressed UNICODE Strings").Value = NewFld.Compressed
			fld.Properties("Jet OLEDB:Allow Zero Length").Value = NewFld.AllowZeroLength
			if not IsNull(NewFld.Description) then fld.Properties("Description").Value = NewFld.Description
			
			'Do not use Default property. It is not always working
			'if not IsNull(NewFld.DefaultValue) then fld.Properties("Default").Value = NewFld.DefaultValue
			
			xCat.Tables(Name_).Columns.Append fld
			CreateField = not Parent_.IsError
			
			set fld = nothing
			set xCat = nothing
		End If
		
		if not Parent_.HasError and not IsNull(NewFld.DefaultValue) then
			call Parent_.Execute("ALTER TABLE [" & Name_ & "] ALTER COLUMN [" & NewFld.Name & "] SET DEFAULT " & NewFld.DefaultValue)
		end if
		
		if not Parent_.HasError and Indexed > 0 then
			Randomize
			if Indexed = 2 then isUnique = True else isUnique = False
			' 赵畅修改于2004.12.17
			CreateIndex "Index_" & CLng(Rnd() * 1000000), NewFld.Name, isUnique, False, 1
		end if
		
	End Function

	'######################################################## 
	'# Deletes an existing field
	Public Function DeleteField(FieldName)
		dim key, sSQL
		
		'find and delete index first
		for each key in Indexes.Keys
			if Indexes_.Item(key).TargetField = CStr(FieldName) then DeleteIndex Indexes_.Item(key).Name, FieldName
		next
		
		'delete the field itself now
		sSQL = "ALTER TABLE [" & Name_ & "] DROP COLUMN [" & FieldName & "]"
		call Parent_.Execute(sSQL)
		DeleteField = not Parent_.IsError
		if not Parent_.HasError and Fields_.Exists(FieldName) then Fields_.Remove FieldName
	End Function

	'######################################################## 
	'# Creates a new index		' 赵畅添加修改于2004.12.19
	Public Function CreateIndex(IndexName, TargetField, IsUnique, IsPrimary, SortOrder)
		dim key, str, strPIndex, sSQL

		str = ""

		if IsPrimary then
			'save all primary keys first, then delete them
			if Len(IndexName) = 0 then IndexName = "PrimaryKey"
			for each key in Indexes.Keys
				if (Indexes_.Item(key).IsPrimary and key = IndexName & "." & TargetField) _
				   or (not Indexes_.Item(key).IsPrimary and Indexes_.Item(key).Name=IndexName) then
					' 出现错误
					Parent_.LastError = "不能在同一索引名中使用相同字段！主键创建失败！"
					CreateIndex = False
					Exit Function
				end if
				if Indexes_.Item(key).IsPrimary then 
					str = str & "[" & Indexes_.Item(key).TargetField & "]"
					if Indexes_.Item(key).SortOrder = 2 then
						str = str & " DESC"
					end if
					str = str & ","
					strPIndex = Indexes_.Item(key).Name
				end if
			next
			If Len(str) > 0 then 
				sSQL = "DROP INDEX [" & strPIndex & "] ON [" & Name_ & "]"
				call Parent_.Execute(sSQL)
			end if
			sSQL = "CREATE INDEX [" & IndexName & "] ON [" & Name_ & "](" & str & "[" & TargetField & "]"
			if SortOrder = 2 then
				sSQL = sSQL & " DESC"
			end if
			sSQL = sSQL & ") WITH PRIMARY"
			call Parent_.Execute(sSQL)
		else

			dim i,IndexItem()
			redim IndexItem(Indexes.Count)

			IndexItem(0) = 0
			for each key in Indexes.Keys
				if (not Indexes_.Item(key).IsPrimary and key = IndexName & "." & TargetField) _
				   or (Indexes_.Item(key).IsPrimary and Indexes_.Item(key).Name=IndexName) then
					' 出现错误
					Parent_.LastError = "不能在同一索引名中使用相同字段！索引创建失败！"
					CreateIndex = False
					Exit Function
				end if
				if Indexes_.Item(key).Name=IndexName then
					set IndexItem(Indexes_.Item(key).Ordinal) = Indexes_.Item(key)
					IndexItem(0) = IndexItem(0) + 1
				end if
			next