inspector.prg

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

LPARAMETERS toObj, tnTop, tnLeft, toCallingForm
IF PCOUNT() = 0
	toObj = SYS(1270)
ENDIF

LOCAL llFromForm
llFromForm = (TYPE("toCallingForm.Name") == "C")

IF llFromForm
	tnTop = toCallingForm.Top
	tnLeft = toCallingForm.Left
ELSE
	tnTop = IIF(EMPTY(tnTop), 0, tnTop)
	tnLeft = IIF(EMPTY(tnLeft), 0, tnLeft)
ENDIF

IF VARTYPE(toObj) # "O"
	WAIT WINDOW NOWAIT "You must pass an object reference to Inspector"
	RETURN
ENDIF

LOCAL lnCnt, lnMem, laMem[1], lcCursor, loForm, llSetClass, lnInspector, lcRef, ;
	lcVal, lcType, llDefault, llReadOnly, lcError, llInsert
lcCursor = SYS(2015)

CREATE CURSOR &lcCursor (cProp C(30), cVal C(80), cType C(1), lDefault L, lReadOnly L)

lnMem = AMEMBERS(laMem, toObj)

* Note: added this error killing since PEMSTATUS produces errors with some ActiveX controls.
lcError = ON("ERROR")
ON ERROR llInsert = .F.
FOR lnCnt = 1 TO lnMem
	IF TYPE("toObj." + laMem[lnCnt]) # "U"
		llInsert = .T.

		IF TYPE("ALEN(toObj." + laMem[lnCnt] + ")") == "N"
			* Array property
			lcType = "A"
			lcVal = "(Array)"
		ELSE
			lcVal = toChar(EVAL("toObj." + laMem[lnCnt]))
			lcType = LEFT(lcVal, 1)
			lcVal = SUBSTR(lcVal, 2)
		ENDIF
		llDefault = !PEMSTATUS(toObj, laMem[lnCnt], 0)
		llReadOnly = PEMSTATUS(toObj, laMem[lnCnt], 1)

		IF llInsert
			INSERT INTO &lcCursor (cProp, cVal, cType, lDefault, lReadOnly) ;
				VALUES (laMem[lnCnt], lcVal, lcType, llDefault, llReadOnly)
		ENDIF
	ENDIF
ENDFOR
ON ERROR &lcError

* Add any methods
lnMem = AMEMBERS(laMem, toObj, 1)
FOR lnCnt = 1 TO lnMem
	IF UPPER(laMem[lnCnt,2]) $ "EVENT,METHOD"
		lcVal = ""
		lcType = "M"
		INSERT INTO &lcCursor (cProp, cVal, cType, lDefault, lReadOnly) ;
			VALUES (laMem[lnCnt,1], lcVal, lcType, .F., .F.)
	ENDIF
ENDFOR

* Now add any contained objects
lnMem = AMEMBERS(laMem, toObj, 2)
FOR lnCnt = 1 TO lnMem
	IF TYPE("toObj." + laMem[lnCnt]) # "U"
		lcVal = toChar(EVAL("toObj." + laMem[lnCnt]))
		lcType = LEFT(lcVal, 1)
		lcVal = SUBSTR(lcVal, 2)
		INSERT INTO &lcCursor (cProp, cVal, cType, lDefault, lReadOnly) ;
			VALUES (laMem[lnCnt], lcVal, lcType, .T., .T.)
	ENDIF
ENDFOR

INDEX ON cType TAG cType
INDEX ON lDefault TAG lDefault
INDEX ON lReadOnly TAG lReadOnly
INDEX ON cProp TAG cProp

LOCATE

IF AT("INSPECTOR", SET("CLASSLIB")) = 0
	llSetClass = .T.
	SET CLASSLIB TO INSPECTOR.VCX ADDITIVE
ENDIF

lnInspector = 1
DO WHILE TYPE("oInspector" + ALLTRIM(STR(lnInspector))) # "U"
	lnInspector = lnInspector + 1
ENDDO
lcRef = "oInspector" + ALLTRIM(STR(lnInspector))
PUBLIC &lcRef
&lcRef = CREATEOBJECT("InspectorForm", toObj, lcRef, tnTop, tnLeft, toCallingForm)

RELEASE toCallingForm

&lcRef..SetGrid(toObj, lcCursor)
&lcRef..Show()

*!*	IF llSetClass
*!*		RELEASE CLASSLIB tJunkCtl
*!*	ENDIF

*!*	IF USED(lcCursor)
*!*		USE IN (lcCursor)
*!*	ENDIF

RETURN


PROCEDURE toChar(tuVal)

LOCAL lcRetVal, lcType
lcRetVal = ""
lcType = TYPE("tuVal")

DO CASE
	CASE lcType = "C"
		lcRetVal = tuVal

	CASE lcType = "N"
		lcRetVal = ALLTRIM(popTrailing(popTrailing(STR(tuVal, 18, 8), "0"), "."))

	CASE lcType = "L"
		lcRetVal = IIF(tuVal, "T", "F")

	CASE lcType = "D"
		lcRetVal = DTOC(tuVal)

	CASE lcType = "Y"
		lcRetVal = ALLTRIM(popTrailing(popTrailing(STR(tuVal, 18, 4), "0"), "."))

	CASE lcType = "T"
		lcRetVal = TTOC(tuVal)

	CASE lcType = "O"
		lcRetVal = IIF(TYPE("tuVal.Name")=="C", tuVal.Name, SET("NULLDISPLAY"))

ENDCASE

RETURN lcType + lcRetVal

ENDPROC


PROCEDURE popTrailing(tcStr, tcChar)

DO WHILE RIGHT(tcStr, 1) = tcChar
	tcStr = LEFT(tcStr, LEN(tcStr) -1)
ENDDO
RETURN tcStr

ENDPROC