utility.prg

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

*-- General purpose utility functions
#INCLUDE "INCLUDE\APPINCL.H"

*-- List of Functions
*  1.  IsTag()
*  2.  NotYet()
*  3.  FileSize()
*  4.  FormIsObject()
*  5.  IsAbstract()
*  6.  ErrorMsg()
*  7.  DoForm()
*  8.  DoBORetValForm(tcClassName, tuParm1)	New -07/19/97 PDH by Charles Blankenship, SAVI
*  9.  ARColHead()
*  10. ConvertToChar()
*  11. IsA()
*  12. IsAddingTB()			 New -07/19/97 PDH taken from TCN Vol 1 Iss 1
*  13. IsAdding()			 Changed -07/19/97 PDH taken from TCN Vol 1 Iss 1
*  14. IsAddingOriginal()	 New -07/19/97 PDH taken from TCN Vol 1 Iss 1
*  15. LockScreen()
*  16. CSZ()
*  17. YesNo()
*  18. GetMessageClass()
*  19. GetWindowsOS()		  Mere Mortals Rev 1.3 p 77 Determing Win OS
*  20. CDToParentDirectory()  Mere Mortals fix for CD .. command bug
*  21. GetFieldName()
*  22. eCompObj()
*  23. CreateHook()
*  24. TrimExt()				EGL: 08/29/2000 - Added because there are calls to it, but no such function can be found!
*--
 
************************************************************
*  FUNCTION IsTag()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  11:07:26
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 1. Returns .T. if the value of tcTagName exists
*)                   : as a tag in either tcAlias or the current alias
*)                   : if tcAlias is not passed
*  Calling Samples...:
*  Parameter List....: Tag name, optional Alias
*  Major change list.:
FUNCTION IsTag(tcTagName, tcAlias)
	LOCAL llIsTag, lcTagFound, lnTagNum

	llIsTag = .F.

	IF PARAMETERS() < 2
		tcAlias = ALIAS()
	ENDIF

	IF USED(tcAlias)
		llIsTag = .F.
		tcTagName = UPPER(ALLTRIM(tcTagName))

		lnTagNum = 1
		lcTagFound = TAG(lnTagNum, tcAlias)
		DO WHILE !EMPTY(lcTagFound)
			IF UPPER(ALLTRIM(lcTagFound)) == tcTagName
				llIsTag = .T.
				EXIT
			ENDIF
			lnTagNum = lnTagNum + 1
			lcTagFound = TAG(lnTagNum, tcAlias)
		ENDDO
	ENDIF

	RETURN llIsTag
ENDFUNC

************************************************************
*  FUNCTION NotYet()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  11:16:20
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 2.
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION NotYet()
	MESSAGEBOX(NOTYET_LOC, MB_ICONINFORMATION, APPNAME_LOC)
	RETURN
ENDFUNC

************************************************************
*  FUNCTION FileSize()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  11:17:33
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 3. Returns the size of a file
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION FileSize(tcFileName)
	LOCAL lcSetCompatible, lnFileSize

	lcSetCompatible = SET("COMPATIBLE")
	SET COMPATIBLE ON
	lnFileSize = FSIZE(tcFileName)
	SET COMPATIBLE &lcSetCompatible
	RETURN lnFileSize
ENDFUNC

***********************************************************
*  FUNCTION FormIsObject()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  11:18:31
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 4. Returns .T. if the active form is an object
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
*	CTB - 09/13/1999 @ 09:16:00pm
*	Added parameter to enhance this function to perform this
*	FormIsObject test on a parameter.

FUNCTION FormIsObject(toObject)
	DO CASE
		CASE PCOUNT() = 0
			RETURN (TYPE("_screen.activeform") == "O" AND UPPER(_screen.ActiveForm.BaseClass) = "FORM")

		CASE PCOUNT() = 1
			RETURN (TYPE("toObject") == "O" AND UPPER(toObject.BaseClass) = "FORM")

	ENDCASE
ENDFUNC


************************************************************
*  FUNCTION IsAbstract()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:06:36
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 5. Handler for abstract classes
*  Calling Samples...: IF IsAbstract(This.Class, "CApplication")
*  Parameter List....:
*  Major change list.:
FUNCTION IsAbstract(tcClass, tcClassName)
	IF UPPER(tcClass) = UPPER(tcClassName)
		?? CHR(7)
		WAIT WINDOW [Cannot instantiate class '] + ALLTRIM(tcClass) + ;
			[' directly!] TIMEOUT 2
		RETURN .T.
	ELSE
		RETURN .F.
	ENDIF
ENDFUNC


************************************************************
*  FUNCTION ErrorMsg()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:08:25
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 6. Used for handling programmer defined error messages
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION ErrorMsg(tcMessage, tnOptions, tcTitle)
	LOCAL lnOptions, ;
		lcTitle

	IF PCOUNT() < 3
		lcTitle = APPNAME_LOC
	ENDIF

	IF PCOUNT() < 2
		lnOptions = MB_ICONEXCLAMATION
	ENDIF

	?? CHR(7)
	MESSAGEBOX(tcMessage, lnOptions, lcTitle)
	RETURN
ENDFUNC


************************************************************
*  FUNCTION DoForm()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:08:45
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 7. Creates and shows forms, and returns values
*)                   : if appropriate
*  Calling Samples...: =DoForm("musicianform")
*                    : IF !DoForm("preferenceform")
*  Parameter List....: tcClassName = name of form class to create
*                    : tuParm1 = optional parameter to pass to form being
*                    :   created
*  Major change list.: 06/27/97 Errata doc change  Added @ to tuParm1
*  ..................: 			in the CREATEOBJECT code to allow passing
*  ..................: 			of array information as well.
*  ..................: 			Also added code to turn the mouse pointer
*  ..................: 			to an hourglass when Launching forms.
FUNCTION DoForm(tcClassName, tuParm1, tuParm2, tuParm3, tuParm4)
	LOCAL loObject, lnOldMousePointer

	*-- 06/27/97 PDH MM 2.0 Additional Tips...
	lnOldMousePointer = _SCREEN.MousePointer
	_SCREEN.MousePointer = MOUSE_HOURGLASS

	DO CASE
		CASE PCOUNT() = 1
			loObject = CREATEOBJECT(tcClassName)

		CASE PCOUNT() = 2
			loObject = CREATEOBJECT(tcClassName, @tuParm1)

		CASE PCOUNT() = 3
			loObject = CREATEOBJECT(tcClassName, @tuParm1, @tuParm2)

		CASE PCOUNT() = 4
			loObject = CREATEOBJECT(tcClassName, @tuParm1, @tuParm2, @tuParm3)

		CASE PCOUNT() = 5
			loObject = CREATEOBJECT(tcClassName, @tuParm1, @tuParm2, @tuParm3, @tuParm4)

	ENDCASE

	IF TYPE("loObject.Name") == "C"
		loObject.Show()

		IF TYPE("loObject.uRetVal") # "U"
			RETURN loObject.uRetVal
		ENDIF

	ENDIF

	_SCREEN.MousePointer = lnOldMousePointer

ENDFUNC


FUNCTION SAVIDoMoverForm(tcClassName, tcSourceAlias, txDestination)
	LOCAL loObject, lnOldMousePointer, llRetVal

	lnOldMousePointer    = _SCREEN.MousePointer
	_SCREEN.MousePointer = MOUSE_HOURGLASS
	llRetVal = .T.

	IF TYPE("tcClassName") == "C"
		loObject = CREATEOBJECT(tcClassName, tcSourceAlias, @txDestination)

		IF TYPE("loObject") == "O" AND !ISNULL(loObject)
			loObject.Show()
			IF loObject.lArray
				ACOPY(loObject.aRetVal, txDestination)
			ENDIF
		ELSE
			llRetVal = .F.
		ENDIF

		_SCREEN.MousePointer = lnOldMousePointer
	ELSE
		llRetVal = .F.
	ENDIF

	RETURN llRetVal
ENDFUNC


FUNCTION SAVIDoArrayRetValForm(tcClassName, taPARM1)
	LOCAL loObject, lnOldMousePointer, llRetVal
	lnOldMousePointer    = _SCREEN.MousePointer
	_SCREEN.MousePointer = MOUSE_HOURGLASS
	llRetVal = .T.

	IF TYPE("tcClassName") == "C"
		loObject = CREATEOBJECT(tcClassName)

		IF TYPE("loObject") == "O" AND !ISNULL(loObject)
			loObject.Show()
			ACOPY(loObject.aRetVal, taPARM1)
		ELSE
			llRetVal = .F.
		ENDIF

		_SCREEN.MousePointer = lnOldMousePointer
	ELSE
		llRetVal = .F.
	ENDIF

	RETURN llRetVal

ENDFUNC


FUNCTION SAVIDoForm(tcClassName, tuParm1)
	LOCAL loObject, lnOldMousePointer, llRetVal

	lnOldMousePointer = _SCREEN.MousePointer
	_SCREEN.MousePointer = MOUSE_HOURGLASS

	IF PCOUNT() < 2
		loObject = CREATEOBJECT(tcClassName)
	ELSE
		loObject = CREATEOBJECT(tcClassName, @tuParm1)
	ENDIF

	IF TYPE("loObject.Name") == "C"
		loObject.Show()

		IF TYPE("loObject.uRetVal") # "U"
			llRetVal = loObject.uRetVal
		ENDIF

	ENDIF

	_SCREEN.MousePointer = lnOldMousePointer

	RETURN llRetVal

ENDFUNC


************************************************************
*)  Description:
*)    Calls a Business Object Return Value form, clears
*)    the form and returns the value
*
*   Parameters:
*     1.  tcClassName - the name of the class from which to create the form
*     2.  tuParm1 - a parameter you want to pass to the .Init() of the form
*
*@  Inputs: None
*   Outputs: None
*$  Usage:
*$     =DoBORetValForm(<tcClassName>,<tuParm1>)
*
*%  Example:
*%     =DoBORetValForm("UserLoginForm") - launches the user login form.
*
*   Returns:  UNKNOWN - determined by the CBizObjRetValForm return value
*   Assumptions: None
*   Rules:  None
*?  Notes:
*?    1.  This program was created simply because I could not get the DoForm()
*?        function to work the way I wanted it.  In order to return the
*?        value, the buisness object retval form could not be destroyed
*?        at the form level due to the necessity of using the .uRetVal property
*?        to find the return value.  DoForm() did not take care of releasing the
*?        cBizObjRetValForm as needed.
*?    2.  DEVELOPER WARNING:  DO NOT populate the <CBizObjRetValForm>.uRetVal
*?        with a value at design time.  Do this only at run time.  Notice
*?        below that the .uRetVal property is evaluated for type "U".  This is
*?        how this program determines if a value was actually returned from the
*?        CBizObjRetValForm.
*
*   Local Routines: None
*-- Process:
*--   1.  Initialize the return value as .F.
*--   2.  IF one parameter was passed
*--   3.     Create the form passing no parameters to it.
*--       ELSE
*--   4.     Create the form passing the specified parameter to it.
*--       ENDIF
*--   5.  IF the form was created
*--   6.     SHOW CBizObjRetValForm
*--   7.     IF a return value was specified
*--             Load the specified return value in the return variable
*--          ENDIF
*--   8.     RELEASE the CBizObjRetValForm
*--       ENDIF
*--   9.  RETURN the value returned from the form.
*--
*
*   Change Log:
*       CREATED Friday, 12/01/95 18:32:32 - CTB:
************************************************************
FUNCTION DoBORetValForm(tcClassName, tuParm1)
	LOCAL loObject, luRetVal
	*           LOCAL/PRIVATE VARIABLE DESCRIPTIONS
	* loObject = holds a local reference to the CBizObjRetValForm
	* luRetVal = holds the value returned by the form

	*-- Assume the call to the Business Object RetVal form failed.
	luRetVal = .F.

	*-- Create the specified form.
	IF PCOUNT() < 2
		loObject = CREATEOBJECT(tcClassName)
	ELSE
		loObject = CREATEOBJECT(tcClassName, tuParm1)
	ENDIF

	*-- IF the form was created, show it and accept
	*-- the return value, then release it from memory.
	IF TYPE("loObject.Name") == "C"
		loObject.Show()
		IF TYPE("loObject.uRetVal") # "U"
			luRetVal = loObject.uRetVal
		ENDIF
		loObject.Release()
	ENDIF

	RETURN luRetVal