gendbcx.prg

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

**  1997.02.24  SEA      Output code within a PROCEDURE / ENDPROC block to
**                       avoid error when compiling procedures > 64K
**  1997.02.24  SEA      Write directly to a single output file, the handle 
**                       of which is passed in hOutFile
**  1997.02.25  SEA      Changed format of CREATE TABLE output code to
**                       improve its readability
**  1997.02.28  SEA      Only write the field ERROR clause if we have
**                       a CHECK clause
**  1997.05.01  SAS      Make two passes throug the routine, the first to
**                       create the table, and the second to create its
**                       properties.
**************************************************************************
PROCEDURE GetTable
	LPARAMETERS cTableName, hOutFile, cProcPrefix

	PRIVATE ALL EXCEPT g_*

	*! Open Table to get field info
	USE (m.cTableName) EXCLUSIVE

	*! Get all the fields
	nNumberOfFields = AFIELDS(aAll_Fields)

	*! Header Information
	=WriteFile(m.hOutFile, "")
	=WriteFile(m.hOutFile, "	**************************************************")
	=WriteFile(m.hOutFile, "	** " + BEGIN_TABLE_LOC + m.cTableName)
	=WriteFile(m.hOutFile, "	**************************************************")
	=WriteFile(m.hOutFile, "	PROCEDURE " + m.cProcPrefix + m.cTableName)
	=WriteFile(m.hOutFile, "	LPARAMETERS tnPassNumber")
	=WriteFile(m.hOutFile, "")
	
	*! NOTE * NOTE * NOTE
	*! If the table is greater than 8 characters then it will fail on platforms that
	*! do not support this (Such as Win32s).
	cOldSetFullPath = SET("FULLPATH")
	SET FULLPATH ON
	cTableFileName = DBF(ALIAS())

	*-- Start pass 1, create the table
	=WriteFile(m.hOutFile, "	DO CASE" + CRLF + "	CASE tnPassNumber = 1")
		
	=WriteFile(m.hOutFile, "		=this.RemoveTable('" + m.cTableName + "', '" + ;
		m.cTableFileName + "')" + CRLF)

	SET FULLPATH OFF
	cTableFileName = DBF(ALIAS())
	IF UPPER(cOldSetFullPath) = "ON"
		SET FULLPATH ON
	ENDIF

	cTableFileName = SUBSTR(m.cTableFileName, RAT(":", m.cTableFileName) + 1)
	cCreateTable = "		CREATE TABLE '" + m.cTableFileName + "' NAME '" + m.cTableName + "' ( ;"
	=WriteFile(m.hOutFile, m.cCreateTable)
	
	*! Information about each field that can been written with CREATE TABLE - SQL
	FOR nInner_Loop = 1 TO m.nNumberOfFields
		cCreateTable = "			" + PADR(aAll_Fields(m.nInner_Loop, 1),MAX(LEN(aAll_Fields(m.nInner_Loop, 1)),20)) + " " + aAll_Fields(m.nInner_Loop, 2)
		DO CASE
			CASE aAll_Fields(m.nInner_Loop, 2) == "C"
				cCreateTable = m.cCreateTable + "(" + ;
								ALLTRIM(STR(aAll_Fields(m.nInner_Loop, 3))) + ")"
				IF aAll_Fields(m.nInner_Loop, 6)
					cCreateTable = m.cCreateTable + " NOCPTRANS"
				ENDIF
			CASE aAll_Fields(m.nInner_Loop, 2) == "M"
				IF aAll_Fields(m.nInner_Loop, 6)
					cCreateTable = m.cCreateTable + " NOCPTRANS"
				ENDIF
			CASE aAll_Fields(m.nInner_Loop, 2) == "N" OR ;
				aAll_Fields(m.nInner_Loop, 2) == "F"
				cCreateTable = m.cCreateTable + "(" + ;
				ALLTRIM(STR(aAll_Fields(m.nInner_Loop, 3))) + ;
				", " + ALLTRIM(STR(aAll_Fields(m.nInner_Loop, 4))) + ")"
			CASE aAll_Fields(m.nInner_Loop, 2) == "B"
				cCreateTable = m.cCreateTable + "(" + ;
				ALLTRIM(STR(aAll_Fields(m.nInner_Loop, 4))) + ")"
		ENDCASE

		IF aAll_Fields(m.nInner_Loop, 5)
			cCreateTable = m.cCreateTable + " NULL"
		ELSE
			cCreateTable = m.cCreateTable + " NOT NULL"
		ENDIF

		*! Get properties for fields
		IF !EMPTY(aAll_Fields[m.nInner_Loop,7])
			cCreateTable = m.cCreateTable + " CHECK " + aAll_Fields[m.nInner_Loop,7]
			*! SEA: Only insert the ERROR message if we have a CHECK clause
			IF !EMPTY(aAll_Fields[m.nInner_Loop,8])
				cCreateTable = m.cCreateTable + " ERROR " + aAll_Fields[m.nInner_Loop,8]
			ENDIF
		ENDIF

		IF !EMPTY(aAll_Fields(m.nInner_Loop, 9))
			cCreateTable = m.cCreateTable + " DEFAULT " + aAll_Fields[m.nInner_Loop,9]
		ENDIF

		IF m.nInner_Loop <> m.nNumberOfFields
			cCreateTable = m.cCreateTable + ", ;"
		ELSE
			cCreateTable = m.cCreateTable + " ;" + CRLF + "		)"
		ENDIF

		=WriteFile(m.hOutFile, m.cCreateTable)
	ENDFOR

	*! Get Index Information
	=WriteFile(m.hOutFile, "")
	=WriteFile(m.hOutFile, "		***** " + BEGIN_INDEX_LOC + m.cTableName + " *****")
	cCollate = ""
	FOR nInner_Loop = 1 TO TAGCOUNT()
		cTag = UPPER(ALLTRIM(TAG(m.nInner_Loop)))
		IF m.cCollate <> IDXCOLLATE(m.nInner_Loop)
			cCollate = IDXCOLLATE(m.nInner_Loop)
			=WriteFile(m.hOutFile, "		SET COLLATE TO '" + m.cCollate + "'")
		ENDIF
		IF !EMPTY(m.cTag)
			DO CASE
				CASE PRIMARY(m.nInner_Loop)
					IF !EMPTY(SYS(2021, m.nInner_Loop))
						IF EMPTY(m.g_cFilterExp)
							=MessageBox(NOT_SUPPORTED_LOC, 64, WARNING_TITLE_LOC)
						ENDIF
						g_cFilterExp = m.g_cFilterExp + CRLF + ;
						               TABLE_NAME_LOC + m.cTableName + CRLF + ;
						               PRIMARY_KEY_LOC + SYS(14, m.nInner_Loop) + CRLF + ;
						               FILTER_EXP_LOC + SYS(2021, m.nInner_Loop)
					ENDIF
					=WriteFile(m.hOutFile, "		ALTER TABLE '" + m.cTableName + ;
						"' ADD PRIMARY KEY " + SYS(14, m.nInner_Loop) ;
						+ " TAG " + m.cTag)

				CASE CANDIDATE(m.nInner_Loop)
					IF EMPTY(SYS(2021, m.nInner_Loop))
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop) + ;
							" TAG " + m.cTag + " CANDIDATE")
					ELSE
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop) + ;
							" TAG " + m.cTag + " FOR " + SYS(2021, m.nInner_Loop) + ;
							+ " CANDIDATE")
					ENDIF

				CASE UNIQUE(m.nInner_Loop)
					IF(EMPTY(SYS(2021, m.nInner_Loop)))
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop) + ;
							" TAG " + m.cTag + " UNIQUE")
					ELSE
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop);
							+ " TAG " + m.cTag + " FOR " + SYS(2021, m.nInner_Loop) ;
							+ " UNIQUE")
					ENDIF

				OTHERWISE
					IF(EMPTY(SYS(2021, m.nInner_Loop)))
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop) + ;
							" TAG " + m.cTag)
					ELSE
						=WriteFile(m.hOutFile, "		INDEX ON " + SYS(14, m.nInner_Loop);
							+ " TAG " + m.cTag + " FOR " + SYS(2021, m.nInner_Loop))
					ENDIF
			ENDCASE
		ELSE
			EXIT FOR
		ENDIF
	ENDFOR
	
	*-- Start pass 2, create the table's properties
	=WriteFile(m.hOutFile, CRLF + "	CASE tnPassNumber = 2")
	
	*! Get Properties For Table
	=WriteFile(m.hOutFile, "")
	=WriteFile(hOutFile, "		***** " + BEGIN_PROP_LOC + m.cTableName + " *****")
	FOR m.nInner_Loop = 1 TO m.nNumberOfFields
		cFieldAlias = m.cTableName + "." + aAll_Fields(m.nInner_Loop, 1)
		cFieldHeaderAlias = [		=DBSetProp('] + m.cFieldAlias + [', 'Field', ]
		cTemp = DBGETPROP(m.cFieldAlias, "Field", "Caption")
		IF !EMPTY(cTemp)
			cTemp = STRTRAN(m.cTemp, ["], ['])
			=WriteFile(hOutFile, m.cFieldHeaderAlias + ['Caption', "] + m.cTemp + [")])
		ENDIF
		cTemp = DBGETPROP(m.cFieldAlias, "Field", "Comment")
		IF !EMPTY(m.cTemp)
			cTemp = STRTRAN(m.cTemp, ["], ['])
			*! Strip Line Feeds
			cTemp = STRTRAN(m.cTemp, CHR(10)) 
			*! Convert Carriage Returns To Programmatic Carriage Returns
			cTemp = STRTRAN(m.cTemp, CHR(13), '" + CHR(13) + "')
			=WriteFile(m.hOutFile, m.cFieldHeaderAlias + ['Comment', "] + m.cTemp + [")])
		ENDIF

		*! The remaining field-level properties don't apply to version 3
		IF "VISUAL FOXPRO" $ upper(version(1)) and !"VISUAL FOXPRO 03" $ upper(version(1))
			* We're not running version 3, so we must be running 5 or higher
			cTemp = DBGETPROP(m.cFieldAlias, "Field", "InputMask")
			IF !EMPTY(m.cTemp)
				m.cTemp = STRTRAN(m.cTemp, ["], ['])
				=WriteFile(m.hOutFile, m.cFieldHeaderAlias + ['InputMask', "] + m.cTemp + [")])
			ENDIF
			cTemp = DBGETPROP(m.cFieldAlias, "Field", "Format")
			IF !EMPTY(m.cTemp)
				cTemp = STRTRAN(m.cTemp, ["], ['])
				=WriteFile(m.hOutFile, m.cFieldHeaderAlias + ['Format', "] + m.cTemp + [")])
			ENDIF
			cTemp = DBGETPROP(m.cFieldAlias, "Field", "DisplayClass")
			IF !EMPTY(m.cTemp)
				cTemp = STRTRAN(m.cTemp, ["], ['])
				=WriteFile(m.hOutFile, m.cFieldHeaderAlias + ['DisplayClass', "] + m.cTemp + [")])
			ENDIF
			cTemp = DBGETPROP(m.cFieldAlias, "Field", "DisplayClassLibrary")
			IF !EMPTY(m.cTemp)
				cTemp = STRTRAN(m.cTemp, ["], ['])
				=WriteFile(m.hOutFile, m.cFieldHeaderAlias + ['DisplayClassLibrary', "] + m.cTemp + [")])
			ENDIF
		ENDIF
	ENDFOR
	
	cTemp = DBGETPROP(m.cTableName, "Table", "Comment")
	IF !EMPTY(m.cTemp)
		cTemp = STRTRAN(m.cTemp, ["], ['])
		*! Strip Line Feeds
		cTemp = STRTRAN(m.cTemp, CHR(10))
		*! Convert Carriage Returns To Programmatic Carriage Returns
		cTemp = STRTRAN(m.cTemp, CHR(13), '" + CHR(13) + "')
		=WriteFile(m.hOutFile, [		=DBSetProp('] + m.cTableName + [', 'Table', ] + ['Comment', "] + m.cTemp + [")])
	ENDIF

	cTemp = DBGETPROP(m.cTableName, "Table", "DeleteTrigger")
	IF !EMPTY(m.cTemp)
		=WriteFile(hOutFile, "		CREATE TRIGGER ON '" + m.cTableName + ;
							  "' FOR DELETE AS " + m.cTemp)
	ENDIF

	cTemp = DBGETPROP(m.cTableName, "Table", "InsertTrigger")
	IF !EMPTY(m.cTemp)
		=WriteFile(m.hOutFile, "		CREATE TRIGGER ON '" + m.cTableName + ;
							  "' FOR INSERT AS " + m.cTemp)
	ENDIF

	cTemp = DBGETPROP(m.cTableName, "Table", "UpdateTrigger")
	IF !EMPTY(m.cTemp)
		=WriteFile(m.hOutFile, "		CREATE TRIGGER ON '" + m.cTableName + ;
							  "' FOR UPDATE AS " + m.cTemp)
	ENDIF

	cTemp = DBGETPROP(m.cTableName, "Table", "RuleExpression")
	IF !EMPTY(m.cTemp)
		cError = DBGETPROP(m.cTableName, "Table", "RuleText")
		IF !EMPTY(cError)
			=WriteFile(m.hOutFile, "		ALTER TABLE '" + m.cTableName + ;
								  "' SET CHECK " + m.cTemp + " ERROR " + ;
								  m.cError)
		ELSE
			=WriteFile(m.hOutFile, "		ALTER TABLE '" + m.cTableName + ;
								  "' SET CHECK " + m.cTemp)
		ENDIF
	ENDIF
	
	=WriteFile(m.hOutFile, "	ENDCASE")
	=WriteFile(m.hOutFile, "	ENDPROC")
	=WriteFile(m.hOutFile, "")
RETURN

**************************************************************************
**
** Function Name: GETVIEW(<ExpC>, <ExpC>)
** Creation Date: 1994.12.01
** Purpose        :
**
**              To take an existing FoxPro 3.0/5.0 View, and generate an output
**              program that can be used to "re-create" that view.
**
** Parameters:
**
**      cViewName        A character string representing the name of the 
**                       existing view
**
**      hOutFile         The handle of the output file
**
**      cProcPrefix      The code we prepend to the view name to create
**                       the name of the procedure within which we wrap the
**                       code that recreates the view
**
** Modification History:
**
**  1994.12.01  JHL      Created Program, runs on Build 329 of FoxPro 3.0
**  1994.12.02  KRT      Added to GenDBC, removed third parameter, cleaned up
**  1994.12.08  KRT      Assume Database is open to speed up operation
**  1996.04.12  KRT      Added new properties for Visual FoxPro 5.0
**                       Prepared / CompareMemo / FetchAsNeeded
**	 1996.05.14  KRT      Added more properties for views
**  1996.05.16  KRT      Adjusted for return a blank string instead of a logical
**                       value on Prepared, etc.. if the field does not exist
**                       in the database (Version 3.0 database converted to 5.0)
**  1996.05.16  KRT      Added the DataType property
**  1996.06.26  KRT      Added support for ParameterList
**  1996.07.19  KRT      Added support for Offline Views
**  1996.08.07  KRT      Added support for BatchUpdateCount, Comment
**  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 GetView
	LPARAMETERS cViewName, hOutFile, cProcPrefix

	PRIVATE ALL EXCEPT g_*

	*! Get View Information for later use
	nSourceType = DBGetProp(m.cViewName, 'View', 'SourceType')
	cConnectName = ALLTRIM(DBGetProp(m.cViewName, 'View', 'ConnectName'))
	cSQL = ALLTRIM(DBGetProp(m.cViewName, 'View', 'SQL'))
	cnUpdateType = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'UpdateType')))
	cnWhereType = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'WhereType')))
	clFetchMemo = IIF(DBGetProp(m.cViewName, 'View', 'Fetchmemo'),'.T.','.F.')
	clShareConnection = IIF(DBGetProp(m.cViewName, 'View', 'ShareConnection'),'.T.','.F.')
	clSendUpdates = IIF(DBGetProp(m.cViewName, 'View', 'SendUpdates'),'.T.','.F.')
	cnUseMemoSize = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'UseMemoSize')))
	cnFetchSize = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'FetchSize')))
	cnMaxRecords = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'MaxRecords')))
	ccTables = ALLTRIM(DBGetProp(m.cViewName, 'View', 'Tables'))
	clPrepared = IIF(!EMPTY(DBGetProp(m.cViewName, 'View', 'Prepared')), '.T.', '.F.')
	clCompareMemo = IIF(!EMPTY(DBGetProp(m.cViewName, 'View', 'CompareMemo')), '.T.', '.F.')
	clFetchAsNeeded = IIF(!EMPTY(DBGetProp(m.cViewName, 'View', 'FetchAsNeeded')), '.T.', '.F.')
	cParams = ALLTRIM(DBGetProp(m.cViewName, 'View', 'ParameterList'))
	lOffline = DBGetProp(m.cViewName, 'View', 'Offline')
	cComment = DBGETPROP(m.cViewName, 'View', 'Comment')
	IF !EMPTY(m.cComment )
		cComment = STRTRAN(m.cComment , ["], ['])
		*! Strip Line Feeds
		cComment = STRTRAN(m.cComment , CHR(10)) 
		*! Convert Carriage Returns To Programmatic Carriage Returns
		cComment = STRTRAN(m.cComment , CHR(13), '" + CHR(13) + "')
	ENDIF
	cnBatchUpdateCount = ALLTRIM(STR(DBGetProp(m.cViewName, 'View', 'BatchUpdateCount')))
	
	*! Generate Heading
	=WriteFile(m.hOutFile, "")
	=WriteFile(m.hOutFile, "	**************************************************")
	=WriteFile(m.hOutFile, "	** " + BEGIN_VIEW_LOC + m.cViewName)
	=WriteFile(m.hOutFile, "	**************************************************")
	=WriteFile(m.hOutFile, "	PROCEDURE " + m.cProcPrefix + m.cViewName)

	*! Generate CREATE VIEW command
	cCreateString = '		CREATE SQL VIEW "' + ALLTRIM(m.cViewName) + '" ; ' + CRLF

	IF m.nSourceType != 1     && If it isn't a local view
		cCreateString = m.cCreateString + '			REMOTE '
		IF !EMPTY(m.cConnectName)
			cCreateString = m.cCreateString + 'CONNECTION "' + m.cConnectName + '" ; '+CRLF
		ENDIF
	ENDIF
	cCreateString = m.cCreateString + '			AS '+ m.cSQL + CRLF

	=WriteFile(m.hOutFile, m.cCreateString)

	*! GENERATE code to Set View Level Properties
	cViewDBSetPrefix = [		=DBSetProp(']+m.cViewName+[', 'View', ]

	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['UpdateType', ] + m.cnUpdateType + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['WhereType', ] + m.cnWhereType + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['FetchMemo', ] + m.clFetchMemo + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['SendUpdates', ] + m.clSendUpdates + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['UseMemoSize', ] + m.cnUseMemoSize + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['FetchSize', ] + m.cnFetchSize + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['MaxRecords', ] + m.cnMaxRecords + [)])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['Tables', '] + m.ccTables + [')])
	=WriteFile(m.hOutFile, m.cViewDBSetPrefix + ['Prepared', ] + m.clPrepared + [)])