objectx.prg

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

*  Program...........: ObjectX.PRG
*  Author............: Ken R. Levy
*  Project...........: Supercls
*  Modified..........: 10/13/1998
*  Author............: Ken R. Levy
*) Description.......: Object extended utilities.


*-- ASCII codes
#DEFINE	LF		CHR(10)
#DEFINE	CR		CHR(13)
#DEFINE CR_LF	CR+LF


LPARAMETERS toObject,tcWindow
LOCAL oObject,oFormObject,oMenuUtilities,lnBar,lcMWindow,lnMRow,lnMCol,lcMenuCommand
LOCAL lnTop,lnLeft,lnTopRatio,lnLeftRatio,lcProperty,luValue,lnCount,lcProgram
LOCAL laSelObj[1]

oObject=IIF(TYPE("toObject")#"O" OR ISNULL(toObject),SYS(1270),toObject)
lcMWindow=IIF(EMPTY(tcWindow),MWINDOW(),ALLTRIM(tcWindow))
lnMRow=MROW(lcMWindow)
lnMCol=MCOL(lcMWindow)
IF TYPE("oObject")#"O" OR ISNULL(oObject) OR TYPE("oObject.ClassLibrary")#"C"
	DO EditX
	RETURN .F.
ENDIF
IF ASELOBJ(laSelObj)=1 AND laSelObj[1].Name==oObject.Name
	RETURN .F.
ENDIF
lnBar=0
DisplayObjectInfo(oObject)
laSelObj=.NULL.
oMenuUtilities=NEWOBJECT("ShortcutMenu","ShctMenu")
oMenuUtilities.AddMenuBar("I\<ntelliSense...","lnBar=1")
oMenuUtilities.AddMenuBar("\<Builder","lnBar=2")
oMenuUtilities.AddMenuBar("\<Class Browser","lnBar=3")
oMenuUtilities.AddMenuBar("\<Save As Class...","lnBar=4")
oMenuUtilities.AddMenuBar("\<Move Object","lnBar=5")
oMenuUtilities.AddMenuBar("C\<opy Properties","lnBar=6")
oMenuUtilities.AddMenuBar("\<Paste Properties","lnBar=7")
oMenuUtilities.AddMenuBar("\<Release Object","lnBar=8")
IF TYPE("_obrowser")=="O" AND NOT ISNULL(_obrowser)
	oMenuUtilities.AddMenuBar("\<Add Object","lnBar=9")
ENDIF
oMenuUtilities.ShowMenu
lnBar=BAR()
DO CASE
	CASE lnBar=0
		RETURN
	CASE lnBar=1
		DO FORM \dev\browser\OLSBldr WITH (oObject)
	CASE lnBar=2
		IF (TYPE("oObject.builder")=="C" AND ;
				NOT EMPTY(oObject.builder)) or ;
				(TYPE("oObject.builderx")=="C" AND ;
				NOT EMPTY(oObject.builderx))
			DO (_builder) with (oObject)
		ELSE
			WAIT WINDOW "Not available for this object" NOWAIT
		ENDIF
	CASE lnBar=3
		IF TYPE("oObject.ClassLibrary")=="C" AND ;
				NOT EMPTY(oObject.ClassLibrary)
			DO (_browser) with (oObject)
		ELSE
			WAIT WINDOW "Not available for this object" NOWAIT
		ENDIF
	CASE lnBar=4
		DO FORM \dev\browser\SaveCls WITH (oObject)	
	CASE lnBar=5
		oFormObject=.NULL.
		IF TYPE("oObject.Top")=="N"
			DO WHILE .T.
				IF TYPE("oObject.parent")#"O"
					EXIT
				ENDIF
				oFormObject=oObject.parent
				IF LOWER(oFormObject.BaseClass)=="form"
					EXIT
				ENDIF
				EXIT
			ENDDO
		ENDIF
		IF NOT ISNULL(oFormObject) AND LOWER(oFormObject.BaseClass)=="form" AND ;
				TYPE("oFormObject.FontName")=="C"
			CLEAR TYPEAHEAD
			WAIT CLEAR
			WAIT WINDOW "Move object..." NOWAIT
			IF INKEY(2,"HM")=151
				WAIT CLEAR
				IF oFormObject.ScaleMode=3
					lnTopRatio=FONTMETRIC(1,oFormObject.FontName,oFormObject.FontSize)
					lnLeftRatio=FONTMETRIC(6,oFormObject.FontName,oFormObject.FontSize)
				ELSE
					lnTopRatio=1
					lnLeftRatio=1
				ENDIF
				DO WHILE MDOWN()
					lnTop=MIN(MROW(oFormObject.Name)*lnTopRatio, ;
							oFormObject.Height-oObject.Height)
					lnLeft=MIN(MCOL(oFormObject.Name)*lnLeftRatio, ;
							oFormObject.Width-oObject.Width)
					IF lnTop>=0 AND oObject.Top#lnTop
						oObject.Top=lnTop
					ENDIF
					IF lnLeft>=0 AND oObject.Left#lnLeft
						oObject.Left=lnLeft
					ENDIF
				ENDDO
			ELSE
				WAIT WINDOW "Move object aborted" NOWAIT
			ENDIF
			oFormObject=.NULL.
		ELSE
			WAIT WINDOW "Not available for this object" NOWAIT
		ENDIF
	CASE lnBar=6
		RELEASE _ClipMembers,_ClipProperties,_ClipObjName,_ClipObjBaseClass
		PUBLIC _ClipMembers[1],_ClipProperties[1]
		PUBLIC _ClipObjName,_ClipObjBaseClass
		DIMENSION _ClipProperties(AMEMBERS(_ClipMembers,oObject))
		FOR lnCount = 1 TO ALEN(_ClipMembers)
			IF NOT INLIST(TYPE("oObject."+_ClipMembers[lnCount]),"O","U")
				_ClipProperties[lnCount]=oObject.&_ClipMembers[lnCount]
			ELSE
				_ClipProperties[lnCount]=.NULL.
			ENDIF
		ENDFOR
		_ClipObjName=oObject.Name
		_ClipObjBaseClass=oObject.BaseClass
		WAIT WINDOW [Object "]+_ClipObjName+[" copied to _ClipProperties] ;
				NOWAIT
	CASE lnBar=7
		IF TYPE("_ClipMembers")#"U" AND NOT ISNULL(_ClipMembers) AND ;
				TYPE("_ClipProperties")#"U" AND ;
				TYPE("_ClipObjName")=="C" AND TYPE("_ClipObjBaseClass")=="C" 
			FOR lnCount = 1 TO ALEN(_ClipMembers)
				lcProperty=LOWER(_ClipMembers[lnCount])
				luValue=_ClipProperties[lnCount]
				IF NOT INLIST(lcProperty,"class","classlibrary","baseclass", ;
						"parentclass","name","top","left","value","tabindex", ;
						"formcount","forms","controlcount","controls", ;
						"caption","pageorder") AND ;
						(oObject.BaseClass==_ClipObjBaseClass OR ;
						NOT INLIST(lcProperty,"height","width")) AND ;
						TYPE("oObject."+lcProperty)#"U" AND ;
						NOT oObject.&lcProperty==luValue
					oObject.&lcProperty=luValue
				ENDIF
			ENDFOR
		ELSE
			WAIT WINDOW "Object does not exist for _ClipProperties" NOWAIT
		ENDIF
	CASE lnBar=8
		ReleaseObject(oObject)
	CASE lnBar=9
		CLEAR TYPEAHEAD
		WAIT CLEAR
		WAIT WINDOW "Add object..." NOWAIT
		IF INKEY(2,"HM")=151
			WAIT CLEAR
			_oBrowser.FormAddObject(oObject)
		ELSE
			WAIT WINDOW "Add object aborted" NOWAIT
		ENDIF
ENDCASE
RETURN



FUNCTION ReleaseObject(toObject)
IF TYPE("toObject")#"O"
	RETURN .F.
ENDIF
IF TYPE("toObject.parent")=="O"
	toObject.parent.RemoveObject(toObject.Name)
ELSE
	toObject.Release
ENDIF
ENDFUNC



FUNCTION DisplayObjectInfo(toObject)
WAIT WINDOW "Object:         "+toObject.Name+CHR(13)+ ;
		"Class:           "+toObject.Class+CHR(13)+ ;
		"ParentClass:  "+toObject.ParentClass+CHR(13)+ ;
		"BaseClass:    "+toObject.BaseClass +CHR(13)+ ;
		"ClassLibrary:  "+toObject.ClassLibrary NOWAIT
ENDFUNC



FUNCTION EditX
LOCAL lnWH,lcClipText,lcLastClipText,lcNewText,lcWindow
LOCAL lnMemoLines,lnLastMemoWidth,lcEndString
EXTERNAL ARRAY RegFn,CallFn,ReleaseWin
EXTERNAL ARRAY _EdOpenFil,_EdCopy,_EdCut,_EdInsert,_EdCloseFile

IF ATC("foxtools.fll",SET("LIBRARY"))=0
	SET LIBRARY TO (HOME()+"FoxTools.FLL") ADDITIVE
ENDIF
lcWindow=MWINDOW()
IF EMPTY(lcWindow) OR TYPE("lcWindow")#"C" OR NOT "."$lcWindow OR NOT WEXIST(lcWindow) OR ;
		NOT FILE(lcWindow)
	RETURN .F.
ENDIF
lcLastClipText=_cliptext
lnWH=_EdOpenFil(lcWindow,2)
IF lnWH<0
	RETURN .F.
ENDIF
_EdCopy(lnWH)
lcClipText=_cliptext
lnLastMemoWidth=SET("MEMO")
SET MEMOWIDTH TO 1024
lnMemoLines=MEMLINES(lcClipText)
SET MEMOWIDTH TO (lnLastMemoWidth)
IF lnMemoLines>=2
	_cliptext=lcLastClipText
	WAIT "EditX Error - Multiple lines selected" WINDOW NOWAIT
	RETURN .F.
ENDIF
DO CASE
	CASE RIGHT(lcClipText,2)==CR_LF
		lcEndString=CR_LF
	CASE RIGHT(lcClipText,1)==CR
		lcEndString=CR
	CASE RIGHT(lcClipText,1)==LF
		lcEndString=LF
	OTHERWISE
		lcEndString=""
ENDCASE
lcNewText=MLINE(lcClipText,1)
DO FORM \dev\browser\OLSBldr WITH lcNewText,lcWindow,.T. TO lcNewText
IF EMPTY(lcNewText)
	_cliptext=lcLastClipText
	RETURN .F.
ENDIF
lcNewText=lcNewText+lcEndString
IF lcNewText==lcClipText
	_cliptext=lcLastClipText
	RETURN .F.
ENDIF
_EdCut(lnWH)
_EdInsert(lnWH,lcNewText,LEN(lcNewText))
_cliptext=lcLastClipText
ENDFUNC