inc_engine.asp

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

			Exit Function
		End If
		
		If not DBAE_DEBUG Then On Error Resume Next
		dim xcat, xtbl
		If Len(AliasName) = 0 Then AliasName = ExternalTable
		Set xcat = Server.CreateObject("ADOX.Catalog")
		if not xcat Is Nothing Then
			Set xcat.ActiveConnection = JetConnection_
			Set xtbl = Server.CreateObject("ADOX.Table")
			With xtbl
				.Name = AliasName
				Set xtbl.ParentCatalog = xcat
				.Properties("Jet OLEDB:Create Link").Value = -1
				If Len(DBpwd) > 0 Then xtbl.Properties("Jet OLEDB:Link Provider String").Value = "MS Access;Pwd=" & DBpwd
				.Properties("Jet OLEDB:Link Datasource").Value = ExternalDBPath
				.Properties("Jet OLEDB:Remote Table Name").Value = ExternalTable
			End With
			xcat.Tables.Append xtbl

			CreateLinkedTable = not IsError
			
			Set xtbl = Nothing
			Set xcat = Nothing
			
		End If
	End Function

	'######################################################## 
	'# Deletes an existing table in database
	Public Function DeleteTable(Name)
		If not IsOpen then
			LastError = "Object is not initialized"
			DeleteTable = False
			Exit Function
		end if
		
		if not DBAE_DEBUG then On Error Resume Next
		JetConnection_.Execute "DROP TABLE [" & Name & "]", adExecuteNoRecords
		
		DeleteTable = not IsError
		if Len(LastError) = 0 Then
			'delete table from tables list
			if Tables_.Exists(Name) then Tables_.Remove Name
		end if
	End Function

	'######################################################## 
	'# Creates a new stored procedure
	Public Function CreateProcedure(Name, Body)
		If not IsOpen then
			LastError = "Object is not initialized"
			CreateProcedure = False
			Exit Function
		end if
		
		dim xCat, cmd
		if not DBAE_DEBUG then On Error Resume Next
		set xCat = Server.CreateObject("ADOX.Catalog")
		If IsEmpty(xCat) or xCat Is Nothing or not UseADOX Then
			Err.Clear
			cmd = "CREATE PROCEDURE [" & Name & "] AS " & Body
			call JetConnection_.Execute(cmd, adExecuteNoRecords)
		Else
			set xCat.ActiveConnection = JetConnection_
			set cmd = Server.CreateObject("ADODB.Command")
			cmd.CommandText = Body
			call xCat.Procedures.Append(Name, cmd)
			
			set cmd = Nothing
			set xCat = Nothing
		End If
		CreateProcedure = not IsError
		if not HasError then
			Procedures_.Item(".uninitialized") = null
		end if
	End Function

	'######################################################## 
	'# Deletes an existing stored procedure
	Public Function DeleteProcedure(Name)
		If not IsOpen then
			LastError = "Object is not initialized"
			DeleteProcedure = False
			Exit Function
		end if
		
		if not DBAE_DEBUG then On Error Resume Next
		JetConnection_.Execute "DROP PROCEDURE [" & Name & "]", adExecuteNoRecords
		
		DeleteProcedure = not IsError
		if not HasError and Procedures_.Exists(Name) then Procedures_.Remove Name
	End Function

	'######################################################## 
	'# Creates a new view
	Public Function CreateView(Name, Body)
		If not IsOpen then
			LastError = "Object is not initialized"
			CreateView = False
			Exit Function
		end if
		
		dim xCat, cmd
		if not DBAE_DEBUG then On Error Resume Next
		set xCat = Server.CreateObject("ADOX.Catalog")
		If IsEmpty(xCat) or xCat Is Nothing or not UseADOX Then
			Err.Clear
			cmd = "CREATE PROCEDURE [" & Name & "] AS " & Body
			call JetConnection_.Execute(cmd, adExecuteNoRecords)
		Else
			set xCat.ActiveConnection = JetConnection_
			set cmd = Server.CreateObject("ADODB.Command")
			cmd.CommandText = Body
			call xCat.Views.Append(Name, cmd)
			
			set cmd = Nothing
			set xCat = Nothing
		End If
		CreateView = not IsError
		if not HasError then
			Views_.Item(".uninitialized") = null
		end if
	End Function

	'######################################################## 
	'# Deletes an existing view
	Public Function DeleteView(Name)
		If not IsOpen then
			LastError = "Object is not initialized"
			DeleteView = False
			Exit Function
		end if
		
		if not DBAE_DEBUG then On Error Resume Next
		JetConnection_.Execute "DROP VIEW [" & Name & "]", adExecuteNoRecords
		
		DeleteView = not IsError
		if Len(LastError) = 0 then 
			if Views_.Exists(Name) then Views_.Remove Name
		end if
	End Function

	'######################################################## 
	'# Creates a new relationship
	Public Function CreateRelation(Name, PKTable, PKField, FKTable, FKField, OnUpdate, OnDelete)
		If not IsOpen then
			LastError = "Object is not initialized"
			CreateRelation = False
			Exit Function
		end if
		
		dim sSQL
		sSQL =	"ALTER TABLE [" & FKTable & "] ADD CONSTRAINT [" &_
				Name & "] FOREIGN KEY ([" & FKField &_
				"]) REFERENCES [" & PKTable & "]([" &_
				PKField & "])"
		if Len(OnUpdate) > 0 then sSQL = sSQL & " ON UPDATE " & OnUpdate
		if Len(OnDelete) > 0 then sSQL = sSQL & " ON DELETE " & OnDelete
		
		if not DBAE_DEBUG then On Error Resume Next
		JetConnection_.Execute sSQL, adExecuteNoRecords
		
		CreateRelation = not IsError
		if Len(LastError) = 0 then 
			Relations_.Item(".uninitialized") = null
		end if
	End Function
	
	'######################################################## 
	'# Deletes an existing relationship
	Public Function DeleteRelation(Name, FKTable)
		If not IsOpen then
			LastError = "Object is not initialized"
			DeleteRelation = False
			Exit Function
		end if
		
		dim sSQL
		sSQL =	"ALTER TABLE [" & FKTable & "] DROP CONSTRAINT [" &_
				Name & "]"
		
		if not DBAE_DEBUG then On Error Resume Next
		JetConnection_.Execute sSQL, adExecuteNoRecords
		
		DeleteRelation = not IsError
		if Len(LastError) = 0 then 
			if Relations_.Exists(Name) then Relations_.Remove Name
		end if
	End Function

	'######################################################## 
	'# Compacts and repaires a database. Converts Access 97 databases to Access 2000
	'# If new password not null, then changes/sets a new password to database
	Public Function CompactDatabase(DoUpgrade, NewPassword, NewLocaleID)
		If not IsOpen then
			LastError = "Object is not initialized"
			CompactDatabase = False
			Exit Function
		end if
		
		dim strTempFile, fso, jro, ver, strCon, strTo, LCID
		set fso = Server.CreateObject("Scripting.FileSystemObject")
		
		strTempFile = DatabasePath_
		strTempFile = Left(strTempFile, InStrRev(strTempFile, "\")) & fso.GetTempName
		set jro = Server.CreateObject("JRO.JetEngine")
		if not DoUpgrade and IsAccess97 then ver = "4" else ver = "5"
		
		'close the database first
		if Len(NewLocaleID) > 0 Then LCID = NewLocaleID Else LCID = JetConnection_.Properties("Locale Identifier").Value
		JetConnection_.Close

		strCon = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DatabasePath_
		if Len(DatabasePassword_) > 0 then strCon = strCon & ";Jet OLEDB:Database password=" & DatabasePassword_
		strTo = "Provider=Microsoft.Jet.OLEDB.4.0; Locale Identifier=" & LCID & "; Data Source=" & strTempFile & "; Jet OLEDB:Engine Type=" & ver
		if Len(DatabasePassword_) > 0 and IsNull(NewPassword) then 
			strTo = strTo & ";Jet OLEDB:Database password=" & DatabasePassword_
		elseif not IsNull(NewPassword) and Len(NewPassword) > 0 then
			strTo = strTo & ";Jet OLEDB:Database password=" & NewPassword
		end if
		
		if not DBAE_DEBUG then On Error Resume Next
		jro.CompactDatabase strCon, strTo

		CompactDatabase = False
		if IsError then
			fso.DeleteFile strTempFile
		else
			fso.DeleteFile DatabasePath_
			fso.MoveFile strTempFile, DatabasePath_
			if IsError then
				fso.DeleteFile strTempFile
			else
				CompactDatabase = True
				if not IsNull(NewPassword) then DatabasePassword_ = NewPassword
			end if
		end if
		set jro = nothing
		set fso = nothing
		
		'reopen the database
		strCon = DBAE_JET_PROVIDER & DatabasePath_
		if Len(DatabasePassword_) > 0 then strCon = strCon & ";Jet OLEDB:Database password=" & DatabasePassword_
		JetConnection_.Open strCon
	End Function
	
	'######################################################## 
	'# Creates a backup copy of opened database
	Public Function BackupDatabase()
		If not IsOpen then
			LastError = "Object is not initialized"
			BackupDatabase = False
			Exit Function
		end if
	
		dim fso, sFileName
		set fso = Server.CreateObject("Scripting.FileSystemObject")
		sFileName = DatabasePath_
		sFileName = Left(sFileName, InStrRev(sFileName, ".")) & "bak"
		
		'close the database first
		JetConnection_.Close
		
		if not DBAE_DEBUG then On Error Resume Next
		fso.CopyFile DatabasePath_, sFileName, True
		
		BackupDatabase = not IsError
		set fso = nothing
		
		'reopen the database
		dim strCon
		strCon = DBAE_JET_PROVIDER & DatabasePath_
		if Len(DatabasePassword_) > 0 then strCon = strCon & ";Jet OLEDB:Database password=" & DatabasePassword_
		JetConnection_.Open strCon
	End Function

	'######################################################## 
	'# Restores a database from previously created backup copy
	Public Function RestoreDatabase()
		If not IsOpen then
			LastError = "Object is not initialized"
			RestoreDatabase = False
			Exit Function
		end if

		dim fso, sFileName
		
		set fso = Server.CreateObject("Scripting.FileSystemObject")
		sFileName = DatabasePath_
		sFileName = Left(sFileName, InStrRev(sFileName, ".")) & "bak"
		
		'close the database first
		JetConnection_.Close
		
		if not DBAE_DEBUG then On Error Resume Next
		fso.CopyFile sFileName, DatabasePath_, True
		
		RestoreDatabase = not IsError
		set fso = nothing
		
		'reopen the database
		dim strCon
		strCon = DBAE_JET_PROVIDER & DatabasePath_
		if Len(DatabasePassword_) > 0 then strCon = strCon & ";Jet OLEDB:Database password=" & DatabasePassword_
		JetConnection_.Open strCon
	End Function

	'######################################################## 
	'# Returns True if the object is initialized
	Public Function IsOpen()
		if IsObject(JetConnection_) and Len(DatabasePath_) > 0 Then IsOpen = True Else IsOpen = False
	End Function

	'######################################################## 
	'# Returns True if any error occured
	Public Function HasError()
		if Len(LastError) > 0 Then HasError = True Else HasError = False
	End Function
	
	'######################################################## 
	'# Resets the object to uninitialized state
	Public Sub Reset()
		Tables_.RemoveAll
		Relations_.RemoveAll
		Views_.RemoveAll
		Procedures_.RemoveAll
		Tables_.Add ".uninitialized", null
		Relations_.Add ".uninitialized", null
		Views_.Add ".uninitialized", null
		Procedures_.Add ".uninitialized", null
		
		DatabasePath_		= ""
		LastError_			= ""
		DatabasePassword_	= ""
		UseADOX_			= True
		
		if IsObject(JetConnection_) Then
			On Error Resume Next
			JetConnection_.Close
			Set JetConnection_ = Nothing
		end if
	End Sub

	'######################################################## 
	'# Checks and update last error
	Function IsError
		If Err then
			LastError = Err.Description & " (" & Err.number & ")"
			IsError = True
			Err.Clear
		else
			LastError = ""
			IsError = False
		end if
	End Function

	'######################################################## 
	'# Executes a script, which can consist of several SQL statements, separated
	'# with ";".
	'# Transaction (Boolean) means run the script as one transaction
	'# IgnoreErrors (Boolean) - finish the script regardless any errors that may occur
	Public Function RunScript(Script, Transaction, IgnoreErrors, ByRef ArrayAffected)
		dim arrSQL, q, rec, intAffected, con, strCon, i, re
		
		if not DBAE_DEBUG then On Error Resume Next
		LastError_ = ""
		if Not IsNull(ArrayAffected) then Redim ArrayAffected(-1)
		Transaction = CBool(Transaction)
		IgnoreErrors = CBool(IgnoreErrors)
		
		'create a new connection object - for adUseClient
		set con = Server.CreateObject("ADODB.Connection")
		con.CursorLocation = adUseClient
		strCon = DBAE_JET_PROVIDER & DatabasePath_
		if Len(DatabasePassword_) > 0 then strCon = strCon & ";Jet OLEDB:Database password=" & DatabasePassword_
		con.Open strCon
		if IsError then Exit Function
		
		if Transaction then call con.BeginTrans

		arrSQL = Split(Script, ";")
		set re = new RegExp
		re.Pattern = "create\s+procedure(.|\n)+parameters(\w|\s)*$"
		re.IgnoreCase = True
		for i=0 to ubound(arrSQL)
			q = arrSQL(i)
			'since Trim doesn't remove vbCrLf from its own reason, then I will delete it
			q = Replace(q, vbCrLf, " ")
			q = Trim(q)
			if re.Test(q) and i < ubound(arrSQL) then
				arrSQL(i+1) = q & "; " & arrSQL(i+1)
				q = ""
			end if
			if Len(q) > 0 then
				set rec = con.Execute(q, intAffected)
				if not IsNull(ArrayAffected) then 
					Redim Preserve ArrayAffected(ubound(ArrayAffected) + 1)
					ArrayAffected(ubound(ArrayAffected)) = CInt(intAffected)
				end if
				if Err then
					LastError_ = LastError_ & Err.Description & vbCrLf
					if not IgnoreErrors then Exit For
					Err.Clear
				end if
			end if
		next
		set re = Nothing
		
		if Transaction and HasError and not IgnoreErrors then
			call con.RollbackTrans
		elseif Transaction then
			call con.CommitTrans
		end if
		
		If not IsObject(rec) then 
			set rec = Server.CreateObject("ADODB.Recordset")
		end if
		
		'detach from connection object
		rec.ActiveConnection = Nothing
		
		con.Close
		set con = Nothing

		set RunScript = rec
	End Function
	
	'########################################################