setup.prg

来自「MSComm控件资料,Visual Basic 6.0(以下简称VB) 是一种功」· PRG 代码 · 共 891 行 · 第 1/2 页

************************************************************
* Program: SETUP.PRG
*
*) Description:
*) This program sets up the Codebook Application
*
*@ Inputs: None
* Outputs: None
*$ Usage/Example: DO SETUP.PRG
* Returns: LOGICAL .T. by default
* Assumptions: None
* Rules: None
* Constraints:
* Performance: None
* Enviornmental: None
*? Notes:
*? 1. Called from MAIN.PRG
*
* Local Routines: None
*-- Process:
*-- 1. Include the application's include file.
*-- 2. If the program is being run from the .APP or .EXE
*-- file, maximize the screen.
*-- 3. Clear the screen and close all databases
*-- 4. Save the values of a few important environmental settings
*-- 5. Reset the mouse pointer to an hourglass while the application
*-- is setting up.
*-- 6. IF the application's path can be established
*-- 7. Create the application object
*-- IF the application object was created
*-- Launch the application
*-- ELSE
*-- Bail out of the application
*-- ENDIF
*-- ELSE
*-- Bail out of the application
*-- ENDIF
*-- 8. Clean up after the application by ...
*-- a. Resetting the mouse pointer
*-- b. Releasing all variables and arrays including public ones
*-- c. Clearing all definitions of all user-defined menu bars, menus, and
*-- windows from memory. CLEAR ALL also removes all external Windows 32-bit
*-- dynamic link libraries (.DLLS) registered with DECLARE - DLL from memory.
*--
*
* Change Log:
* CREATED Sunday, 10/29/95 15:16:06 - CTB:
*		MODIFIED Friday, 09/18/1998 10:19:32 - CTB:
*		Added localized variables as per Dan Welter
*		Prevented the CBMeta table from being deleted
*		if the project is being used by another process
*
************************************************************
#INCLUDE "INCLUDE\APPINCL.H"

#DEFINE SECURITY_OVERRIDE_STRING		"DynamiteStone"
#DEFINE APPLICATION_MAINTENANCE_STRING	"DarkStarDown"
LPARAMETERS tlSetPathOnly

IF INLIST(RIGHT(SYS(16,1), 3), "APP", "EXE")
	_screen.WindowState = WINDOWSTATE_MAXIMIZED
ENDIF

CLEAR
CLOSE DATA ALL

*-- Save the settings of a few important environmental settings.
*-- All public vars will be released as soon as the application
*-- object is created.
IF SET("TALK") = "ON"
	SET TALK OFF
	PUBLIC gcOldTalk
	gcOldTalk = "ON"
ELSE
	PUBLIC gcOldTalk
	gcOldTalk = "OFF"
ENDIF

*** EGL: 2001.12.27 23:21 -  Added save and restore of SET RESOURCE settings
LOCAL lcReso, lcReso1
lcReso = SET("RESOURCE")
lcReso1 = SET("RESOURCE", 1)

PUBLIC gcOldDir, gcOldPath, gcOldClassLib, gcOldProcedure, gcFilterCondition, gcAction
LOCAL lcOldPath
lcOldPath = SET("PATH")

gcOldDir = FULLPATH(CURDIR())
gcOldPath = SET("PATH")
gcOldClassLib = SET("CLASSLIB")
gcOldProcedure = SET("PROCEDURE")
gcFilterCondition = ""
gcAction = ""

*-- Since we won't return to this program until the program runs, or
*-- never return to it at all in case of error, the MousePointer
*-- property will be reset in the application's do method.
_screen.MousePointer = MOUSE_HOURGLASS

*-- Set up the path so we can instantiate the application object
IF SetPath()
	IF tlSetPathOnly
		RETURN
	ENDIF

	PUBLIC goApp
	goApp = CREATEOBJECT(APPCLASS)

	IF TYPE("goApp.Name") == "C"
		LOCAL llSuccessfulLogin

		llSuccessfulLogin = PerformLoginProcessing()
		IF llSuccessfulLogin
			*-- Release all public vars, since their values were
			*-- picked up by the Environment class
			RELEASE gcOldTalk, gcOldDir, gcOldPath, gcOldClassLib, gcOldProcedure

			WITH goApp
				.SetupApplicationOnKeyLabels()
				.SetupApplicationPublicVariables()
				.ActivateDBCXManager()
				.PostLoginProcessing()

				*-- Do the application
				.Do()
			ENDWITH

		ELSE

			goApp.Release()

		ENDIF

	ENDIF
ENDIF

*-- Cleanup after the application is terminated.
_screen.MousePointer = MOUSE_DEFAULT

SET PATH TO (lcOldPath)
*** EGL: 2001.12.27 23:21 -  Added save and restore of SET RESOURCE settings
*!*	SET RESOURCE TO (lcReso1)
*!*	SET RESOURCE &lcReso

RELEASE ALL EXTENDED
CLEAR ALL

IF INLIST(RIGHT(SYS(16,1), 3), "APP", "EXE")
	QUIT
ENDIF

RETURN


FUNCTION GetFFPath(tcFoxFirePath)
	*-- Assume default directory is FF30V and
	*-- that DBPATHS does not exist.
	*-- *** May need to be updated for future versions of FoxFire. ***
	tcFoxFirePath = ".\FF30V\"

	LOCAL lnSelect, llRetVal, llOK2Close, llDebugMode
	lnSelect = SELECT(0)
	llRetVal = .F.
	llDebugMode = goApp.lDebugMode

	IF USED("dbpaths")
		SELECT dbpaths
		llOK2Close = .F.
	ELSE
		IF FILE("dbpaths.dbf")
			SELECT 0
			USE dbpaths AGAIN SHARED
		ENDIF
		llOK2Close = .T.
	ENDIF

	llRetVal = USED("dbpaths")

	IF llRetVal
		LOCATE FOR "FOXFIRE!" $ UPPER(ALLTRIM(cdb_desc))

		IF FOUND()
			tcFoxFirePath = ALLTRIM(cdb_local)
		ELSE
			IF llDebugMode
				MESSAGEBOX("Could not find a reference to FOXFIRE! in the DBPATHS file.")
			ENDIF
		ENDIF
	ENDIF

	IF USED("dbpaths") AND llOK2Close
		USE IN dbpaths
	ENDIF

	llRetVal = DIRECTORY(tcFoxFirePath)
	SELECT (lnSelect)

	RETURN llRetVal
ENDFUNC


FUNCTION ReturnDirectory(tcDirectoryDescription, tcLocalRemote)
	LOCAL lcDirectory
	lcDirectory = ""

	IF GetDirectory (tcDirectoryDescription, tcLocalRemote, @lcDirectory)
		RETURN ""
	ELSE
		RETURN lcDirectory
	ENDIF

	RETURN
ENDFUNC


FUNCTION GetDirectory(tcDirectoryDescription, tcLocalRemote, tcDirectory)
	LOCAL lnSelect, lcPath, llRetVal, llFound

	*-- Initialize locals
	lnSelect = SELECT(0)
	lcPath = ""
	llRetVal = .F.
	llFound = .F.

	IF FILE("DBPATHS.DBF")
		IF USED("dbpaths")
			SELECT dbpaths
		ELSE
			SELECT 0
			USE dbpaths AGAIN SHARED ALIAS dbpaths
		ENDIF

		*-- This is a very small table, the performance hit
		*-- for using LOCATE versus SEEK is negligible
		LOCATE FOR ALLTRIM(UPPER(dbpaths.cdb_desc)) == ALLTRIM(UPPER(tcDirectoryDescription))

		IF FOUND()
			DO CASE
				CASE TYPE("tcLocalRemote") = "L"
					IF dbpaths.lLocalData
						tcDirectory = ALLTRIM(dbpaths.cdb_local)
					ELSE
						tcDirectory = ALLTRIM(dbpaths.cdb_remote)
					ENDIF

				CASE UPPER(tcLocalRemote) = "LOCAL"
					tcDirectory = ALLTRIM(dbpaths.cdb_local)

				CASE UPPER(tcLocalRemote) = "REMOTE"
					tcDirectory = ALLTRIM(dbpaths.cdb_remote)

			ENDCASE

			llRetVal = DIRECTORY(tcDirectory)

		ENDIF

		SELECT (lnSelect)

		IF USED("dbpaths")
			USE IN dbpaths
		ENDIF

	ENDIF

	RETURN llRetVal
ENDFUNC


FUNCTION GetPath(tcDatabaseName, tcLocalRemote)
	LOCAL lnSelect, lcPath
	lnSelect = SELECT(0)
	*-- Assume the default Codebook database path
	lcPath = ".\DATA\"

	IF FILE("DBPATHS.DBF")
		IF USED("dbpaths")
			SELECT dbpaths
		ELSE
			SELECT 0
			USE dbpaths AGAIN SHARED ALIAS dbpaths
		ENDIF

		*** EGL: 12/06/1999 - Force the SEEK to UPPER()
		***IF SEEK(tcDatabaseName, "dbpaths", "cDB_Name")
		IF SEEK(UPPER(tcDatabaseName), "dbpaths", "cDB_Name")
			DO CASE

				CASE TYPE("tcLocalRemote") = "L"
					IF dbpaths.lLocalData
						lcPath = ALLTRIM(dbpaths.cdb_local)
					ELSE
						lcPath = ALLTRIM(dbpaths.cdb_remote)
					ENDIF

				CASE UPPER(tcLocalRemote) = "LOCAL"
					lcPath = ALLTRIM(dbpaths.cdb_local)

				CASE UPPER(tcLocalRemote) = "REMOTE"
					lcPath = ALLTRIM(dbpaths.cdb_remote)

			ENDCASE
		ENDIF

		SELECT (lnSelect)

		IF USED("dbpaths")
			USE IN dbpaths
		ENDIF

	ENDIF

	RETURN lcPath
ENDFUNC


FUNCTION GetTablePath(tcDatabaseName, tcPath)
	LOCAL llRetVal, lcDatabaseName
	llRetVal = FILE("dbpaths.dbf")
	lcDatabaseName = ALLTRIM(UPPER(tcDatabaseName))

	IF llRetVal AND NOT USED("dbpaths")
		SELECT 0
		USE dbpaths ALIAS dbpaths SHARED
	ENDIF

	llRetVal = USED("dbpaths")
	IF llRetVal
		*** EGL: 12/06/1999 - Force the SEEK to UPPER()
		***llRetVal = SEEK(lcDatabaseName, "dbpaths", "cdb_name")
		llRetVal = SEEK(UPPER(lcDatabaseName), "dbpaths", "cdb_name")
		IF llRetVal
			tcPath = ALLTRIM(dbpaths.cdb_local)
		ENDIF
	ENDIF

	RETURN llRetVal
ENDFUNC


FUNCTION GetSecurityFile(tcSecurityFile)
	LOCAL lnSelect, llRetVal
	lnSelect = SELECT(0)
	llRetVal = .F.
	tcSecurityFile = ""

	*** EGL: 2002.1.2 14:18 -  Changed the extension from .TXT to .CTB. It was confusing 
	***   the CVS software because it is actually binary, not text.
	IF FILE("SECURITY\WALSH64.CTB")
		tcSecurityFile = "SECURITY\WALSH64.CTB"
	ELSE

		llRetVal = FILE("dbpaths.dbf")

		IF llRetVal AND NOT USED("dbpaths")
			SELECT 0
			USE dbpaths AGAIN SHARED ALIAS dbpaths
		ENDIF

		llRetVal = USED("dbpaths")
		IF llRetVal
			llRetVal = SEEK("SECURITY", "dbpaths", "cdb_name")
			IF llRetVal
				tcSecurityFile = ALLTRIM(dbpaths.cdb_local) + "WALSH64.CTB"
			ENDIF
		ENDIF

	ENDIF

	llRetVal = FILE(tcSecurityFile)

	SELECT (lnSelect)

	RETURN llRetVal
ENDFUNC


FUNCTION PerformLoginProcessing()
	LOCAL llSuccessfulLogin, lcSecurityFile, lnSelect
	llSuccessfulLogin = .F.
	lcSecurityFile = ""

	IF GetSecurityFile(@lcSecurityFile)
		IF USED("walsh64")
			SELECT walsh64
		ELSE
			lnSelect = SELECT(0)
			SELECT 0
			USE (lcSecurityFile) ALIAS walsh64
		ENDIF

		DO CASE
			CASE IsMaintenanceBeingPerformed()
				llSuccessfulLogin = .F.

			CASE GetSecurityOverride()
				llSuccessfulLogin = .T.

			OTHERWISE
				llSuccessfulLogin = SAVIDoForm("ALoginForm")

		ENDCASE

		IF USED("walsh64")
			USE IN walsh64
		ENDIF
	ENDIF

	RETURN llSuccessfulLogin
ENDFUNC


FUNCTION IsMaintenanceBeingPerformed()
	LOCAL llMaint, lcError
	llMaint = .F.
	lcError = ON("ERROR")
	ON ERROR llMaint = .F.

	llMaint = (ALLTRIM(walsh64.field1) == APPLICATION_MAINTENANCE_STRING)
	ON ERROR &lcError

	IF llMaint
		MESSAGEBOX(APPLICATION_MAINTENANCE_MESSAGE,0,APPNAME_LOC)
	ENDIF

	RETURN llMaint
ENDFUNC


FUNCTION GetSecurityOverride()
	LOCAL llOverrideSecurity, lcError
	llOverrideSecurity = .F.
	lcError = ON("ERROR")

	ON ERROR llOverrideSecurity = .F.
	llOverrideSecurity = (ALLTRIM(walsh64.field1) == SECURITY_OVERRIDE_STRING)
	ON ERROR &lcError

	RETURN llOverrideSecurity
ENDFUNC


************************************************************
* FUNCTION: SetPath()
*
*) Description: