newapp.prg

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

#INCLUDE "INCLUDE\APPINCL.H"
#DEFINE		CRLF		CHR(13) + CHR(10)

CLOSE ALL
CLEAR ALL

LOCAL loForm, loTalk, loNotify, loSafety, lcCurDir, loExclusive, loExact

SET CLASSLIB TO Forms, CUtils, ICollect, IHooks ADDITIVE
SET PROC TO utility, setup ADDITIVE

CREATE CURSOR crsTextFile (mWork M)
APPEND BLANK

loTalk = CREATEOBJECT("CSet", "TALK", "OFF")
loNotify = CREATEOBJECT("CSet", "NOTIFY", "OFF")
loSafety = CREATEOBJECT("CSet", "SAFETY", "OFF")
loExclusive = CREATEOBJECT("CSet", "EXCLUSIVE", "ON")
loExact = CREATEOBJECT("CSet", "EXACT", "OFF")
lcCurDir = FULLPATH(CURDIR())

loForm = CREATEOBJECT("QuickStartForm")
loForm.Show()

CD (lcCurDir)
RELEASE CLASSLIB forms
RELEASE PROCEDURE utility
RELEASE PROCEDURE setup

CLOSE ALL
CLEAR PROGRAM

RETURN

************************************************************
* PROCEDURE MakeProj()
************************************************************
* Author............: Paul Bienick
* Project...........: Codebook 3.0
* Created...........: 08/03/95 23:46:17
* Copyright.........: (c) Flash Creative Management, Inc., 1995
* Copyright.........: (c) Software Assets of Virginia, Inc., 1997
*) Description.......:
* Calling Samples...:
* Parameter List....:
* Major change list.:
************************************************************
PROCEDURE MakeProj(toForm)
	LOCAL lnSelect, lcCurDir, lcProject, lcAppNameLoc, lcTemplateDir, lcCommonPath, ;
	lcCompanyName, lcDestinationDir, lcApplicationClass, loFoxTools, llClassMenus, ;
	lcMenuFileName

	WITH toForm
		*-- Ask the main form for all the strings we need to create the application
		lcCurDir = FULLPATH(CURDIR())
		lcProject = ALLTRIM(UPPER(.GetProject()))
		lcAppNameLoc = .GetApplication()
		lcTemplateDir = .GetTemplate()
		lcCommonPath = .GetCommon()
		lcCompanyName = .GetCompany()
		lcDestinationDir = .GetDestination()
		lcApplicationClass = .GetAppClass()
		llUseIntegerKeys = (.GetKeyType() == "I")
		llClassMenus = (.GetMenuType() == "CLASS")
		lcMenuFileName = IIF(llClassMenus, "", .GetMenuFileName())
	ENDWITH

	*-- We need FoxTools for some of the cool
	*-- functionality it provides ...
	loFoxTools = CREATEOBJECT("CFoxTools")

	OpenTextFileTable(@lnSelect)

	*-- Do not include this WAIT WINDOW in the CopyDir() function
	*-- due to its use of recursion ... the window would flash
	*-- repeatedly as each directory is being created
	WAIT WINDOW "Creating directories ..." NOWAIT

	IF CopyDir(lcTemplateDir, lcDestinationDir, loFoxTools)

		CD (lcCurDir)

		MkIncludeDBF(lcDestinationDir, lcApplicationClass, lcAppNameLoc, ;
			lcCompanyName, lcProject, lcCommonPath)

		*-- At this point, you are in the new project's subdirectory.
		*-- You CD'd to here in the MkIncludeDBF ...
		*-- please notice how programming in the problem domain
		*-- practically spells out what this application really does.
		*-- For more information on programming in the problem domain
		*-- see Steve McConnell's book, Code Complete, Chapter 32.
		*-- The ISBN is 1-55615-484-4. For a FoxPro specific application
		*-- of these concepts see The Codebook News, Volume 1 Issue 2,
		*-- "Programming In The Problem Domain". You can download this
		*-- issue from the following URL:
		*-- http://www.savvysolutions.com/vol1iss2.zip.
		*------------------------------------------------------------
		MkIncludeH(lcCommonPath)
		MkADataEnv(lcApplicationClass, lcProject)
		MkStartCB(lcCommonPath, lcProject)
		MkMain(lcCommonPath)
		UpdateAppRefs(lcProject, lcCommonPath, lcDestinationDir, lcMenuFileName)

		*** EGL: 12/22/1999 - Create the DBC from scratch instead
		*UpdateApplicationDBCStoredProcedures(lcCommonPath, lcProject)
		*RenameDBCAndUpdateLinkToIDTable(lcAppNameLoc, lcProject)
		CreateProjectDBC(lcProject, lcCommonPath, llUseIntegerKeys)

		UpdateSecDBCProcs(lcCommonPath)
		RenameDBC(lcProject)
		UpdateLocations(lcCommonPath)
		UpdateAppClass(lcApplicationClass, llClassMenus, lcMenuFileName)
		IF llClassMenus
			RemoveMPRFromPJX(lcProject, lcDestinationDir)
		ELSE
			RemoveMenusFromPJX(lcProject, lcDestinationDir)
		ENDIF
		
		*** EGL: 2001.12.27 10:59:18 - Added support for VFP 7 menus
		SetProperMenuVersion(llClassMenus, lcDestinationDir, lcMenuFileName)
		
		UpdateDBPaths(lcProject, lcDestinationDir)
		NotifyComplete(lcAppNameLoc, lcDestinationDir)
		COMPILE STARTCB.PRG
	ELSE
		MESSAGEBOX("Unable to create sub-directory!", 48, lcAppNameLoc)
		RETURN .F.
	ENDIF

	CloseTextFileTable(lnSelect)

ENDPROC


FUNCTION OpenTextFileTable(tnSelect)

	tnSelect = SELECT(0)
	SELECT 0
	USE TextFile.DBF

	RETURN
ENDFUNC


FUNCTION CloseTextFileTable(tnSelect)

	*!*	IF USED("TextFile")
	*!*		SELECT TextFile
	*!*		SCAN
	*!*			REPLACE TextFile.mWork WITH ""
	*!*		ENDSCAN
	*!*		USE IN TextFile
	*!*	ENDIF

	SELECT (tnSelect)
	RETURN
ENDFUNC

************************************************************
* FUNCTION CopyDir()
************************************************************
* Author............: Paul Bienick
* Project...........: Codebook 3.0
* Created...........: 08/03/95 23:41:48
* Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: Copies directories
* Calling Samples...:
* Parameter List....:
* Major change list.:
************************************************************
FUNCTION CopyDir(tcSourceDir, tcTargetDir, toFoxTools)

	LOCAL laFiles[1, 5], lcSourceDir, lcTargetDir, lnFile, loFoxTools, lcSourceFile, ;
		lcTargetFile, lcError, laTest[1]

	lcSourceDir = tcSourceDir
	lcTargetDir = tcTargetDir

	CD (lcSourceDir)

	IF RIGHT(lcSourceDir, 1) # "\"
		lcSourceDir = lcSourceDir + "\"
	ENDIF

	IF RIGHT(lcTargetDir, 1) # "\"
		lcTargetDir = lcTargetDir + "\"
	ENDIF

	*-- Make top level target directory if it does not exist
	CheckDir(tcTargetDir, toFoxTools)

	lnNumFiles = ADIR(laFiles, lcSourceDir + "*.*", "D")

	IF lnNumFiles > 0
		FOR lnFile = 1 TO lnNumFiles

			*-- Ignore current and Parent directories
			IF laFiles[lnFile, 1] = "."
				LOOP
			ENDIF

			*-- Check if subdirectory
			IF "D" $ laFiles[lnFile, 5]
				*-- Use recursion to create sub-directories
				CopyDir(lcSourceDir + laFiles[lnFile, 1], lcTargetDir + laFiles[lnFile, 1], ;
					toFoxTools)
			ELSE
				*-- Copy the file
				lcSourceFile = lcSourceDir + laFiles[lnFile, 1]
				lcTargetFile = lcTargetDir + laFiles[lnFile, 1]
				COPY FILE (lcSourceFile) TO (lcTargetFile)
			ENDIF

		ENDFOR
	ENDIF

	WAIT CLEAR

	RETURN
ENDFUNC

************************************************************
* FUNCTION CheckDir()
************************************************************
* Author............: Paul Bienick
* Project...........: Codebook 3.0
* Created...........: 08/10/95 19:39:07
* Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: Checks if directories exist and creates
*) : them as necessary.
* Calling Samples...:
* Parameter List....:
* Major change list.:
************************************************************
FUNCTION CheckDir(tcTargetDir, toFoxTools)
	LOCAL lnSlash, lcOldOnError, lnErrorNum

	lcOldOnError = ON("ERROR")
	lnErrorNum = 0
	IF !toFoxTools.IsDir(tcTargetDir)
		*-- Trap for an invalid file path or name error (202)
		ON ERROR lnErrorNum = ERROR()
		MD (tcTargetDir)
		ON ERROR &lcOldOnError
		IF lnErrorNum > 0
			IF lnErrorNum # 202
				ERROR lnErrorNum
			ELSE
				*-- Tried to execute something like: "MD \DIR1\DIR2"
				*-- which is not supported. We'll have to create 1
				*-- directory at a time.
				FOR lnSlash = 2 TO OCCURS("\", tcTargetDir)
					MD (LEFT(tcTargetDir, AT("\", tcTargetDir, lnSlash)))
				ENDFOR
			ENDIF
		ENDIF
	ENDIF
	RETURN
ENDFUNC


FUNCTION MkIncludeDBF(tcDestinationDir, tcApplicationClass, tcAppNameLoc, tcCompanyName, ;
		tcProject, tcCommonPath)

	*-- If recursive copy successful, change
	*-- directory to destination dir
	CD (tcDestinationDir)

	WAIT WINDOW "Updating project components ..." NOWAIT

	*-- Update APPINCL.DBF
	*-- (file is named appincl2 since appincl is included in
	*-- this app, which is in memory.)
	SELECT 0
	USE include\appincl2 ORDER key
	IF SEEK("APPCLASS")
		REPLACE string WITH tcApplicationClass
	ENDIF
	IF SEEK("APPNAME_LOC")
		REPLACE string WITH tcAppNameLoc
	ENDIF
	IF SEEK("COMPANYNAME_LOC")
		REPLACE string WITH tcCompanyName
	ENDIF
	IF SEEK("INIFILE")
		REPLACE string WITH (tcProject + ".INI")
	ENDIF
	IF SEEK("PJX_NAME")
		REPLACE string WITH (tcProject + ".PJX")
	ENDIF
	IF SEEK("COMMONPATH")
		REPLACE string WITH (tcCommonPath)
	ENDIF

	USE

	CD include
	RENAME appincl2.dbf TO appincl.dbf
	RENAME appincl2.cdx TO appincl.cdx
	RENAME appincl2.fpt TO appincl.fpt

	*-- CD ..
	*-- Modification: 08/26/1997 08:32:00 - CTB: added function
	*-- call that fixes problems with the CD .. command
	*-- CDToParentDirectory() located in the UTILITY.PRG
	*-----------------------------------------------------------
	CDToParentDirectory()

	WAIT CLEAR

	RETURN
ENDFUNC


FUNCTION MkIncludeH(tcCommonPath)

	SELECT TextFile
	LOCATE FOR TextFile.cFileName = "APPINCL.H"
	IF FOUND()
		REPLACE crsTextFile.mWork WITH STRTRAN(TextFile.mText, "<common_path>", ;
			LEFT(UPPER(tcCommonPath), LEN(tcCommonPath) - 1))
		COPY MEMO crsTextFile.mWork TO Include\AppIncl.h
	ENDIF
	RETURN
ENDFUNC


FUNCTION MkADataEnv(tcApplicationClass, tcProject)
	SELECT TextFile
	LOCATE FOR TextFile.cFileName = "ADATAENV.PRG"
	IF FOUND()
		REPLACE crsTextFile.mWork WITH STRTRAN(TextFile.mText, "<appclass>", tcApplicationClass)
		REPLACE crsTextFile.mWork WITH STRTRAN(crsTextFile.mWork, "<pjxname>", UPPER(tcproject))
		COPY MEMO crsTextFile.mWork TO libs\aDataEnv.prg
	ENDIF

	RETURN
ENDFUNC


FUNCTION MkStartCB(tcCommonPath, tcProject)

	SELECT TextFile
	LOCATE FOR TextFile.cFileName = "STARTCB.PRG"
	IF FOUND()
		REPLACE crsTextFile.mWork WITH STRTRAN(TextFile.mText, "<common_path>", ;
			LEFT(UPPER(tcCommonPath), LEN(tcCommonPath)-1))
		REPLACE crsTextFile.mWork WITH STRTRAN(crsTextFile.mWork, "<pjxname>", UPPER(tcProject))
		COPY MEMO crsTextFile.mWork TO StartCB.prg
	ENDIF
	RETURN
ENDFUNC