gendbcx.prg

MSComm控件资料,Visual Basic 6.0(以下简称VB) 是一种功能强大、简单易学的程序设计语言。它不但保留了原先Basic语言的全部功能

lcObjectName = "oDBC"
lcClassName = IIF(TYPE("tcClassName")="C",tcClassName,"sdGenDBC")
lcGenAllProc = "GenerateAll"
=WriteFile(m.hOutFile, ;
	"LPARAMETERS tcMethod" + CRLF + ;
	"LOCAL " + lcObjectName + CRLF + CRLF + ;
	lcObjectName + " = CreateObject('" + m.lcClassName + "')" + CRLF + ;
	"IF EMPTY(tcMethod)" + CRLF + ;
	"	=" + lcObjectName + "." + m.lcGenAllProc + "()" + CRLF + ;
	"ELSE" + CRLF + ;
	"	=EVALUATE('" + lcObjectName + ".' + tcMethod)" + CRLF + ;
	"ENDIF" + CRLF + CRLF ;
)

*! Begin defining the class
=WriteFile(m.hOutFile, ;
	"DEFINE CLASS " + m.lcClassName + " AS Custom" + CRLF + ;
	"	PROTECTED aTables[1]" + CRLF + ;
	"	PROTECTED nTables" + CRLF ;
)

*! Write the CustomProcess method
#IFDEF CUSTOM_METHOD_LOC
   =WriteFile(m.hOutFile, ;
      "	PROCEDURE CustomProcess" + CRLF + ;
      CUSTOM_METHOD_LOC + ;
      "	ENDPROC" + CRLF ;
      )
#ELSE
   =WriteFile(m.hOutFile, ;
      "	PROCEDURE CustomProcess" + CRLF + ;
      "		*-- Your code goes here" + CRLF + ;
      "	ENDPROC" + CRLF ;
      )
#ENDIF

*! Write the Init method, storing the names of any tables in an existing dbc
*! into the class' "table names" array
=WriteFile(m.hOutFile, ;
	"	PROCEDURE Init" + CRLF + ;
	"		IF FILE('" + m.g_cDatabase + "')" + CRLF + ;
	"			OPEN DATABASE " + m.g_cDatabase + CRLF + ;
	"			this.nTables = ADBOBJECTS(this.aTables, 'Table')" + CRLF + ;
	"		ENDIF" + CRLF + ;
	"	ENDPROC" + CRLF ;
)

*! Begin the database container recreation method
lcCreateDBCProc = "CreateDBC"
=WriteFile(m.hOutFile, ;
	"	PROCEDURE " + m.lcCreateDBCProc + CRLF + ;
	"		CLOSE DATA ALL" + CRLF + ;
	"		CREATE DATABASE '" + m.g_cDatabase + "'" + CRLF ;
)

*! Create the call to the DBC recreation method, to be inserted into the
*! "summary" method below
lcCDStr = CRLF + TAB + TAB + CREATE_DBC_LOC + CRLF + TAB + TAB + "=this." + m.lcCreateDBCProc + "()" + CRLF

*! If the database contained any stored procedures (i.e. we wrote something
*! other than the NO_MODIFY_LOC constant to the .k$$ file), then output
*! the code required to recreate the procedure file.
=ADIR(aTemp, m.cSPTemp)
IF m.aTemp[1, 2] > LEN(NO_MODIFY_LOC) + 2
	=WriteFile(m.hOutFile, "")
	=WriteFile(m.hOutFile, "		********* " + BEGIN_PROC_LOC + " *********")
	=WriteFile(m.hOutFile, "		IF !FILE([" + SUBSTR(m.cFile, RAT("\", m.cFile) + 1) + "])")
	=WriteFile(m.hOutFile, "			? [" + NO_FILE_FOUND_LOC + "]")
	=WriteFile(m.hOutFile, "		ELSE")
	=WriteFile(m.hOutFile, "			CLOSE DATABASE")
	=WriteFile(m.hOutFile, "			USE '" +  m.g_cDatabase + "'")
	=WriteFile(m.hOutFile, "			g_SetSafety = SET('SAFETY')")
	=WriteFile(m.hOutFile, "			SET SAFETY OFF")
	=WriteFile(m.hOutFile, "			LOCATE FOR Objectname = 'StoredProceduresSource'")
	=WriteFile(m.hOutFile, "			IF FOUND()")
	=WriteFile(m.hOutFile, "				APPEND MEMO Code FROM [" + SUBSTR(m.cFile, RAT("\", m.cFile) + 1) + "] OVERWRITE")
	=WriteFile(m.hOutFile, "				REPLACE Code WITH SUBSTR(Code, " + ALLTRIM(STR(LEN(NO_MODIFY_LOC) + 3)) + ", " + ALLTRIM(STR(m.nSourceSize - 2)) + ")")
	=WriteFile(m.hOutFile, "			ENDIF")
	=WriteFile(m.hOutFile, "			LOCATE FOR Objectname = 'StoredProceduresObject'")
	=WriteFile(m.hOutFile, "			IF FOUND()")
	=WriteFile(m.hOutFile, "				APPEND MEMO Code FROM [" + SUBSTR(m.cFile, RAT("\", m.cFile) + 1) + "] OVERWRITE")
	=WriteFile(m.hOutFile, "				REPLACE Code WITH SUBSTR(Code, " + ALLTRIM(STR(LEN(NO_MODIFY_LOC) + m.nSourceSize + 1)) + ")")
	=WriteFile(m.hOutFile, "			ENDIF")
	=WriteFile(m.hOutFile, "			IF UPPER(g_SetSafety) = 'ON'")
	=WriteFile(m.hOutFile, "				SET SAFETY ON")
	=WriteFile(m.hOutFile, "			ENDIF")
	=WriteFile(m.hOutFile, "			USE")
	=WriteFile(m.hOutFile, "			OPEN DATABASE [" + m.g_cDatabase + "]")
	=WriteFile(m.hOutFile, "		ENDIF")
	=WriteFile(m.hOutFile, "")
ELSE
	ERASE (m.cSPTemp)
ENDIF

*! Close the database container recreation method
=WriteFile(m.hOutFile, "	ENDPROC" + CRLF)

=Stat_Message()

**************************
*** Get Tables
**************************

lcCTStr1 = ""
lcCTStr2 = ""

lcProcPrefix = "tb"
IF m.nTotal_Tables > 0
	
	lcCTStr1 = CRLF + TAB + TAB + CREATE_TABLES_LOC + CRLF
	lcCTStr2 = CRLF + TAB + TAB + FINISH_TABLES_LOC + CRLF
	
	FOR m.nLoop = 1 TO m.nTotal_Tables
		DO GetTable WITH ALLTRIM(aAll_Tables(m.nLoop)), m.hOutFile, m.lcProcPrefix
		lcCTStr1 = lcCTStr1 + TAB + TAB + "=this." + m.lcProcPrefix + ALLTRIM(aAll_Tables[m.nLoop]) + "(1)" + CRLF
		lcCTStr2 = lcCTStr2 + TAB + TAB + "=this." + m.lcProcPrefix + ALLTRIM(aAll_Tables[m.nLoop]) + "(2)" + CRLF
		=Stat_Message()
	ENDFOR
	
	
ENDIF

**************************
*** Get Connections
**************************
lcCCStr = ""
lcProcPrefix = "cn"
IF m.nTotal_Connections > 0
	lcCCStr = CRLF + TAB + TAB + CREATE_CONNECTIONS_LOC + CRLF
	FOR m.nLoop = 1 TO m.nTotal_Connections
		DO GetConn WITH aAll_Connections(m.nLoop), m.hOutFile, m.lcProcPrefix
		lcCCStr = lcCCStr + TAB + TAB + "=this." + m.lcProcPrefix + ALLTRIM(aAll_Connections[m.nLoop]) + "()" + CRLF
		=Stat_Message()
	ENDFOR
ENDIF

**************************
*** Get Views
**************************
lcCVStr = ""
lcProcPrefix = "vw"
IF m.nTotal_Views > 0
	lcCVStr = CRLF + TAB + TAB + CREATE_VIEWS_LOC + CRLF
	FOR m.nLoop = 1 TO m.nTotal_Views
		DO GetView WITH ALLTRIM(aAll_Views(m.nLoop)), m.hOutFile, m.lcProcPrefix
		lcCVStr = lcCVStr + TAB + TAB + "=this." + m.lcProcPrefix + ALLTRIM(aAll_Views[m.nLoop]) + "()" + CRLF
		=Stat_Message()
	ENDFOR
ENDIF

**************************
*** Get Relations
**************************
lcSetRelStr = ""
lcProcName = "SetRelations"
IF m.nTotal_Relations > 0
	lcSetRelStr = CRLF + TAB + TAB + "=this." + m.lcProcName + "()" + CRLF
	LOCAL lcRelString
	lcRelString = CRLF + TAB + "***** " + BEGIN_RELATION_LOC + " *****" + ;
	              CRLF + TAB + "PROCEDURE " + m.lcProcName + CRLF
	FOR m.nLoop = 1 TO m.nTotal_Relations
		lcRelString = lcRelString + TAB + TAB + "ALTER TABLE '" + aAll_Relations[m.nLoop,1] +;
							 "' ADD FOREIGN KEY TAG " +;
							 aAll_Relations[m.nLoop,3] +;
							 " REFERENCES " + ;
							 aAll_Relations[m.nLoop,2] +;
							 " TAG " + aAll_Relations[m.nLoop,4] + CRLF
		*! SEA: As mentioned above, we process relations so fast now, it's better 
		*! not to include them in the progress bar, as they distort the indicator
		* =Stat_Message()
	ENDFOR
	lcRelString = m.lcRelString + TAB + "ENDPROC" + CRLF
	=WriteFile(m.hOutFile, m.lcRelString)
ENDIF

CLOSE DATABASE  && Because we're going to start peeking into the
                && table structure of the DBC

**************************
*** Get RI Info
**************************
lcSetRIStr = ""
lcProcName = "SetRI"
IF m.nTotal_Relations > 0
	DO GetRI WITH m.hOutFile, m.lcProcName
	lcSetRIStr = CRLF + TAB + TAB + "=this." + m.lcProcName + "()" + CRLF
ENDIF
=Stat_Message()

*! Create the RemoveTable() function, which allows individual methods to
*! recreate a table that is part of the database, but has been accidentally
*! erased.
=WriteFile(m.hOutFile, CRLF + ;
	"	FUNCTION RemoveTable(tcTable, tcFile)" + CRLF + ;
	"		LOCAL ARRAY laTables[1]" + CRLF + ;
	"		=ADBOBJECTS(laTables,'Table')" + CRLF + ;
	"		IF ASCAN(laTables,tcTable) = 0" + CRLF + ;
	"			*-- No such table in the current dbc, nothing to do!" + CRLF + ;
	"			RETURN .t." + CRLF + ;
	"		ENDIF" + CRLF + ;
	"		IF !FILE(tcFile)" + CRLF + ;
	"			*-- If the file has been erased, REMOVE TABLE fails with a 'File does not" + CRLF + ;
	"			*-- exist' error, because it can't find the file to either remove its" + CRLF + ;
	"			*-- database reference or delete the file <sigh>." + CRLF + ;
	"			*-- We'll work around this problem by creating a phony file with the same" + CRLF + ;
	"			*-- name, and use REMOVE TABLE DELETE to both remove the table reference" + CRLF + ;
	"			*-- in the dbc, and erase the phony file." + CRLF + ;
	"			LOCAL lhFile" + CRLF + ;
	"			lhFile = FCREATE(tcFile)" + CRLF + ;
	"			if lhFile = -1" + CRLF + ;
	"				RETURN .f." + CRLF + ;
	"			ENDIF" + CRLF + ;
	"			=FCLOSE(lhFile)" + CRLF + ;
	"		ENDIF" + CRLF + ;
	"		REMOVE TABLE (tcTable) DELETE" + CRLF + ;
	"		=ADBOBJECTS(laTables,'Table')" + CRLF + ;
	"		RETURN ASCAN(laTables,tcTable) > 0" + CRLF + ;
	"	ENDFUNC" + CRLF ;
)

*! Create the "summary" procedure that calls all the other procedures
*! to create tables, views, etc.
=WriteFile(m.hOutFile, "")
=WriteFile(m.hOutFile, "	PROCEDURE " + lcGenAllProc)

=WriteFile(m.hOutFile, lcCDStr+lcCTStr1+lcHookStr+lcCTStr2+lcCCStr+lcCVStr+lcSetRelStr+lcSetRIStr)

=WriteFile(m.hOutFile, "	ENDPROC")

*! End the class definition
=WriteFile(m.hOutFile, "ENDDEFINE")

*! Make the output file(s) permanent
=FCLOSE(m.hOutFile)
COPY FILE (m.cDPTemp) TO (m.tcOutFile)
ERASE (m.cDPTemp)
IF FILE(m.cSPTemp)
	COPY FILE (m.cSPTemp) to (m.cFile)
	ERASE (m.cSPTemp)
ENDIF

=Stat_Message()

COMPILE (m.tcOutFile)

=GenDBC_CleanUp(.T.)
*********************** END OF PROGRAM ***********************

**************************************************************************
**
** Function Name: GETRI(<ExpC>)
** Creation Date: 1994.12.02
** Purpose:
**
**      To take existing FoxPro 3.0/5.0 RI Infomration, and generate an output
**      program that can be used to "re-create" this.
**
** Parameters:
**
**      hOutFile  - The file handle of the output file
**      cProcName - A character string containing the name of the
**                  current procedure
**
** Modification History:
**
**  1995.01.05  KRT    Created function
**  1995.12.20  KRT    Allow better lookup when trying to find
**                     the right record to add the RI information
**  1997.02.24  SEA    Output code within a PROCEDURE / ENDPROC block to
**                     avoid error when compiling procedures > 64K
**                     database re-creation program a procedure
**  1997.02.24  SEA    Write directly to a single output file, the handle 
**                     of which is passed in hOutFile
**************************************************************************
PROCEDURE GetRI
	LPARAMETERS hOutFile, cProcName

	PRIVATE ALL EXCEPT g_*

	=WriteFile(m.hOutFile, "	***** " + BEGIN_RI_LOC + " *****")
	=WriteFile(m.hOutFile, "	PROCEDURE " + cProcName)

	*! USE the database
	USE (m.g_cFullDatabase) EXCLUSIVE

	LOCATE FOR ObjectType = "Relation" AND !EMPTY(RiInfo)
	IF FOUND()
		=WriteFile(m.hOutFile, "		CLOSE DATABASE")
		=WriteFile(m.hOutFile, "		USE '" +  m.g_cDatabase + "'")
		DO WHILE FOUND()
			*! Have to get the parent name to verify we are adding
			*! Information to the right record.
			m.nParentID = ParentID
			*! We use select so we won't mess up our LOCATE ... CONTINUE command
			SELECT ObjectName FROM (m.g_cFullDatabase) WHERE ObjectID = nParentID INTO ARRAY aTableName
			nStart = 1
			cITag = ""
			cTable = ""
			cRTag = ""
			DO WHILE m.nStart <= LEN(Property)
				nSize = ASC(SUBSTR(Property, m.nStart, 1)) +;
				(ASC(SUBSTR(Property, m.nStart + 1, 1)) * 256) +;
				(ASC(SUBSTR(Property, m.nStart + 2, 1)) * 256^2) + ;
				(ASC(SUBSTR(Property, m.nStart + 3, 1)) * 256^3)

				nKey = ASC(SUBSTR(Property, m.nStart + 6, 1))

				DO CASE
					CASE m.nKey = 13
						cITag = SUBSTR(Property, m.nStart + 7, m.nSize - 8)
					CASE m.nKey = 18
						cTable = SUBSTR(Property, m.nStart + 7, m.nSize - 8)
					CASE m.nKey = 19
						cRTag = SUBSTR(Property, m.nStart + 7, m.nSize - 8)
				ENDCASE
				nStart = m.nStart + m.nSize
			ENDDO
			=WriteFile(m.hOutFile, "		LOCATE FOR ObjectType = 'Table' AND ObjectName = '" + ;
						 ALLTRIM(aTableName(1)) + "'")
			=WriteFile(m.hOutFile, "		IF FOUND()")
			=WriteFile(m.hOutFile, "			nObjectID = ObjectID")
			=WriteFile(m.hOutFile, " 			LOCATE FOR ObjectType = 'Relation' AND '" + m.cITag + ;
						"'$Property AND '" + m.cTable + "'$Property AND '" + m.cRTag + ;
						"'$Property AND ParentID = nObjectID")
			=WriteFile(m.hOutFile, "			IF FOUND()")
			=WriteFile(m.hOutFile, "				REPLACE RiInfo WITH '" + RiInfo + "'")
			=WriteFile(m.hOutFile, "			ELSE")
			=WriteFile(m.hOutFile, '				? "' + NO_FIND_LOC + ', line " + ltrim(str(lineno()))')
			=WriteFile(m.hOutFile, "			ENDIF")
			=WriteFile(m.hOutFile, "		ENDIF")
			CONTINUE
		ENDDO
		=WriteFile(m.hOutFile, "		USE")
	ENDIF
	USE
	=WriteFile(m.hOutFile, "	ENDPROC")
RETURN

**************************************************************************
**
** Function Name: GETTABLE(<ExpC>, <ExpC>)
** Creation Date: 1994.12.01
** Purpose        :
**
**              To take an existing FoxPro 3.0/5.0 Table, and generate an output
**              program that can be used to "re-create" that Table.
**
** Parameters:
**
**      cTableName       A character string representing the name of the
**                       existing Table
**
**      hOutFile         The handle of the output file
**
**      cProcPrefix      The code we prepend to the table name to create
**                       the name of the procedure within which we wrap the
**                       code that recreates the table
**
** Modification History:
**
**  1994.12.02  KRT      Created function
**  1994.12.05  KRT      Made it a function and cleaned it up
**  1994.12.08  KRT      Assume Database is open to speed up operation
**  1995.09.15  KRT      Use DBF() to find the real table name
**  1995.09.15  KRT      Take into account CR+LF in comment fields
**  1996.04.12  KRT      Added new properties for Visual FoxPro 5.0
**                       InputMask / Format / DisplayClass
**                       DisplayClassLibrary
**  1996.06.01  KRT      Added support for Collate sequence on index