builderx.prg

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

*  Program...........: BUILDERX.PRG
*  Author............: Ken R. Levy
*  Project...........: 
*  Created...........: 07/16/1995
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: Wrapper program for _Builder.
LPARAMETERS toObject , ;
            tuSource , ;
            tcRunBuilder

LOCAL lcBuilder  , ;
      lcBuilder2 ,;
      llControlInit
      
LOCAL laSelObj[1]

*--------------------------------------
*--	Check for a public memvar _BuilderX
*-- to override \vfp\builder.app.
*--------------------------------------
IF TYPE( '_BuilderX' )=='C' AND NOT EMPTY( _BuilderX )
	RETURN DoBuilder(toObject, tuSource, _BuilderX)
ENDIF

lcBuilder=HOME() + 'builder.app'

IF TYPE('toObject')#'O'
	IF ASELOBJ(laSelObj)#1
		IF TYPE('tuSource')#'C'
			tuSource=''
		ENDIF
		DO (lcBuilder) WITH (toObject),(tuSource)
		RETURN
	ENDIF
	toObject=laSelObj[1]
	laSelObj=.F.
ENDIF

*--	Check for form object containing a lControlInit property.
IF NOT ISNULL(tcRunBuilder) AND NOT toObject.BaseClass=='Form' AND ;
		TYPE('toObject.parent.lControlInit')=='L' AND ;
		toObject.parent.lControlInit AND EMPTY(toObject.Comment)
	lcControlInit=toObject.parent.ReadMethod('ControlInit')
	RELEASE o
	PRIVATE o
	o=toObject
	=CodeBlck( lcControlInit )
	RELEASE o
	IF EMPTY(toObject.Comment)
		toObject.Comment='*'
	ENDIF
	IF NOT toObject.parent.lControlBuilder
		RETURN
	ENDIF
ENDIF

*--	Check for object containing a Builder property.
IF NOT ISNULL(tcRunBuilder)

*-- Check for specified tcRunBuilder.
	IF TYPE('tcRunBuilder')=='C'
		IF NOT EMPTY(tcRunBuilder)
			RETURN DoBuilder(toObject,tuSource,tcRunBuilder,.T.)
		ENDIF
		DO (lcBuilder) WITH (toObject),(tuSource)
		RETURN
	ENDIF

*-- Check for specified BuilderX property.
	IF TYPE('toObject.BuilderX')=='C' AND NOT EMPTY(toObject.BuilderX)
		RETURN DoBuilder(toObject,tuSource,toObject.BuilderX)
	ENDIF

*-- Check for specified Builder property.
	IF TYPE('toObject.Builder')=='C' AND NOT EMPTY(toObject.Builder)
		RETURN DoBuilder(toObject,tuSource,toObject.Builder)
	ENDIF

ENDIF

IF NOT EMPTY(lcBuilder) AND NOT FILE(lcBuilder)
	lcBuilder2=LOWER(FULLPATH(TrimPath(lcBuilder),HOME()))
	IF NOT FILE(lcBuilder2)
		=FileNotFoundMsg(lcBuilder)
		RETURN .F.
	ENDIF
	lcBuilder=lcBuilder2
ENDIF
IF TYPE('tuSource')#'C'
	tuSource=''
ENDIF
DO (lcBuilder) WITH (toObject),(tuSource)
RETURN



FUNCTION DoBuilder( toObject, tuSource, tcBuilder, tlSkipSearch )

LOCAL lcBuilder , ;
      lnAtPos   , ;
      lcClass   , ;
      lcLastOnError
      
LOCAL laInstance[1]

lcBuilder=ALLTRIM(MLINE(tcBuilder,1))

lnAtPos=AT(',',lcBuilder)

IF lnAtPos=0
	lcClass=''
ELSE
	lcClass=LOWER(ALLTRIM(SUBSTR(lcBuilder,lnAtPos+1)))
	lcBuilder=LOWER(ALLTRIM(MLINE(LEFT(lcBuilder,lnAtPos-1),1)))
	IF EMPTY(lcBuilder)
		lcBuilder=toObject.ClassLibrary
	ENDIF
	IF NOT EMPTY(lcBuilder) AND NOT '.'$lcBuilder
		lcBuilder=lcBuilder+'.vcx'
	ENDIF
ENDIF

IF lcBuilder=='?'
*--	Execute dialog to select builder program.
	lcBuilder=GETFILE('prg;scx;app','Select Builder program:','Open')
	IF EMPTY(lcBuilder)
		RETURN
	ENDIF
ENDIF

IF lcBuilder=='*'
*--	Create public reference o and activate the Command window.
	RELEASE o
	PUBLIC o
	o=toObject
	WAIT WINDOW LEFT('Name:  '+toObject.Name+SPACE(10)+CHR(13)+ ;
			'Type: '+tuSource+SPACE(10)+CHR(13)+ ;
			'Class:  '+toObject.Class+SPACE(10)+CHR(13)+ ;
			'ParentClass:  '+toObject.ParentClass+SPACE(10)+CHR(13)+ ;
			'Base Class:  '+toObject.BaseClass+SPACE(10)+CHR(13)+ ;
			'Reference:  o'+SPACE(10),254) NOWAIT
	ACTIVATE WINDOW Command
	RETURN
ENDIF

*--	Execute builder specified in _BuilderX memvar.
IF NOT EMPTY(lcBuilder) AND NOT '.'$lcBuilder
	lcBuilder=lcBuilder+'.prg'
ENDIF
IF (NOT EMPTY(lcBuilder) OR EMPTY(lcClass)) AND NOT FILE(lcBuilder)
	IF NOT '\'$lcBuilder
		lcBuilder=FULLPATH(TrimPath(lcBuilder),toObject.ClassLibrary)
	ENDIF
	IF NOT FILE(lcBuilder)
		lcBuilder2=LOWER(FULLPATH(TrimPath(lcBuilder),HOME()))
		IF NOT FILE(lcBuilder2)
			=FileNotFoundMsg(lcBuilder)
			RETURN .F.
		ENDIF
		lcBuilder=lcBuilder2
	ENDIF
ENDIF
DO CASE
	CASE NOT EMPTY(lcClass)
		IF TYPE('_BuilderEdit')=='L' AND _BuilderEdit
			_BuilderEdit=.F.
			IF AINSTANCE(laInstance,lcClass)>0
				WAIT WINDOW "Class '"+lcClass+"' is in use" NOWAIT
				RETURN
			ENDIF
			MODIFY CLASS (lcClass) OF (lcBuilder) NOWAIT
			RETURN
		ENDIF
		lcLastSetClassLib=SET('CLASSLIB')
		SET CLASSLIB TO (lcBuilder) ADDITIVE
		lnCount=0
		DO WHILE .T.
			lnCount=lnCount+1
			lcObjName=PROPER(lcClass+ALLTRIM(STR(lnCount)))
			IF TYPE(lcObjName)=='U'
				EXIT
			ENDIF
		ENDDO
		lcLastOnError=ON('ERROR')
		ON ERROR =.F.
		oNewObject=CREATEOBJECT(lcClass,toObject,tuSource,tlSkipSearch)
		IF EMPTY(lcLastOnError)
			ON ERROR
		ELSE
			ON ERROR &lcLastOnError
		ENDIF
		IF TYPE('oNewObject')#'O' OR ISNULL(oNewObject)
			IF NOT SET('CLASSLIB')==lcLastSetClassLib
				RELEASE CLASSLIB (lcBuilder)
			ENDIF
			RETURN ShowMsg("Class ("+lcClass+ ;
					") of '"+LOWER(lcBuilder)+"' could not be instantiated.")
			RETURN .F.
		ENDIF
		PUBLIC (lcObjName)
		lcCode=lcObjname+[=oNewObject]
		&lcCode
		IF NOT SET('CLASSLIB')==lcLastSetClassLib
			RELEASE CLASSLIB (lcBuilder)
		ENDIF
		IF oNewObject.lAutoShow
			oNewObject.Show()
		ENDIF
		IF TYPE('oNewObject')#'O' OR ISNULL(oNewObject)
			RETURN .F.
		ENDIF
		IF oNewObject.lAutoRelease
			oNewObject.Release()
			RELEASE (lcObjName)
		ENDIF
		RETURN
	CASE LOWER(RIGHT(lcBuilder,4))=='.scx'
		IF TYPE('_BuilderEdit')=='L' AND _BuilderEdit
			_BuilderEdit=.F.
			MODIFY FORM (lcBuilder) NOWAIT
			RETURN
		ENDIF
		DO FORM (lcBuilder) WITH (toObject),(tuSource)
		RETURN
	CASE LOWER(RIGHT(lcBuilder,4))=='.vcx'
		RETURN ShowMsg("File '"+LOWER(lcBuilder)+ ;
				"' requires class name (ex. TestLib,TestClass).")
	CASE LOWER(RIGHT(lcBuilder,4))=='.prg'
		IF TYPE('_BuilderEdit')=='L' AND _BuilderEdit
			_BuilderEdit=.F.
			MODIFY COMM (lcBuilder) NOWAIT
			RETURN
		ENDIF
		DO FORM (lcBuilder) WITH (toObject),(tuSource)
		RETURN
ENDCASE
IF TYPE('tuSource')#'C'
	tuSource=''
ENDIF
DO (lcBuilder) WITH (toObject),(tuSource)
RETURN



FUNCTION ShowMsg
LPARAMETERS tcMessage
LOCAL lnResult

lnResult=MESSAGEBOX(tcMessage,48,'BuilderX')
WAIT CLEAR
RETURN lnResult



FUNCTION FileNotFoundMsg
LPARAMETERS tcFileName

RETURN ShowMsg("File '"+LOWER(tcFileName)+"' not found.")



PROCEDURE TrimPath
LPARAMETERS tcFileName,tlTrimExt,tlPlatformType
LOCAL lcFileName,lnAtPos

IF EMPTY(tcFileName)
	RETURN ''
ENDIF
lcFileName=tcFileName
lnAtPos=AT(':',lcFileName)
IF lnAtPos>0
	lcFileName=SUBSTR(lcFileName,lnAtPos+1)
ENDIF
IF tlTrimExt
	lcFileName=trimext(lcFileName)
ENDIF
IF tlPlatformType
	lcFileName=IIF(_dos OR _unix,UPPER(lcFileName),LOWER(lcFileName))
ENDIF
lcFileName=ALLTRIM(SUBSTR(lcFileName,AT('\',lcFileName,;
		MAX(OCCURS('\',lcFileName),1))+1))
DO WHILE LEFT(lcFileName,1)=='.'
	lcFileName=ALLTRIM(SUBSTR(lcFileName,2))
ENDDO
DO WHILE RIGHT(lcFileName,1)=='.'
	lcFileName=ALLTRIM(LEFT(lcFileName,LEN(lcFileName)-1))
ENDDO
RETURN lcFileName