utility.prg

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

		tnDefaultButton = 0
	ENDIF

	IF tnDefaultButton = 1
		tnDialogType = tnDialogType + MB_DEFBUTTON2
	ENDIF

	IF TYPE("tcTitleText") # "C"
		tcTitleText = APPNAME_LOC
	ENDIF

	IF tlBeep
		?? CHR(7)
	ENDIF

	RETURN MESSAGEBOX(tcMessage, tnDialogType, tcTitleText) = IDYES
ENDFUNC


************************************************************
*   FUNCTION:  GetMessageClass()
*
*)  Description: 18.
*)     Returns the name of the message class specified for the
*)     application.  Defaults to "CMessage" class, Codebook's
*)     default message class if another one has not been provided.
*)
*@  Inputs:
*      1.  Property - goApp.cMessageClass
*@
*   Outputs: None
*
*$  Usage: =GetMessageClass()
*$
*%  Example: lcMessageClass = GetMessageClass()
*%
*   Returns:  CHARACTER - the name of the application's message class
*   Assumptions:
*     1.  The message class exists.  This function does not check
*         to see if the class definition for the specified message
*         class can be found.
*   Rules:  None
*   Constraints:
*     Performance: None
*     Enviornmental: None
*
*?  Notes:
*?    To change the application's message class from the
*     Codebook default simply change the goApp.cMessageClass
*     property to the desired message class.
*
*   Local Routines: None
*-- Process:
*--    1.  Return the application's message class
*--        if provided.
*--    2.  IF not provided ... use cMessage as a default.
*--
*
*   Change Log:
*       CREATED Sunday, 10/29/95 19:00:43 - CTB:
************************************************************
FUNCTION GetMessageClass()
	*-- If the cMessageClass property of the application
	*-- object has been provided, use that as this
	*-- application's messaging object ... otherwise use
	*-- Codebook's CMessage class.
	IF TYPE("goApp.cMessageClass") == "C" AND !EMPTY(goApp.cMessageClass)
		RETURN goApp.cMessageClass
	ELSE
		RETURN "CMessage"
	ENDIF
	
	RETURN
ENDFUNC


************************************************************
*  FUNCTION GetWindowsOS()
************************************************************
*  Author............: Rick Strahl
*  Project...........: Codebook 3.0
*  Created...........: 03/12/1997  00:13:57
*  Copyright.........: (c) Star Dot Star Business Systems, Inc, 1997
*) Description.......: 19. Mere Mortals Rev 1.3 Determines which
*) ..................: Windows OS an application is running and saves
*) ..................: the value to an application.
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION GetWindowsOS
	LOCAL lcOS
	DO CASE
		CASE FILE(GETENV("WINDIR")+"\SYSTEM32\USER32.DLL")
			lcOS = "WINNT"
			
		CASE FILE(GETENV("WINDIR")+"\SYSTEM\USER32.DLL")
			lcOS = "WIN95"
			
		CASE FILE(GETENV("WINDIR")+"\SYSTEM\WIN32s\W32SCOMB.DLL")
			lcOS = "WIN31"
			
	ENDCASE
	
	RETURN lcOS
ENDFUNC


************************************************************
*  FUNCTION CDToParentDirectory()
************************************************************
*  Author............: Kevin McNeish (and some Chinese guy)
*  Project...........: Codebook 3.0
*  Created...........: 08/26/1997  08:12:00
*  Copyright.........: Public Domain
*) Description.......: CD .. doesn't always work ... whereas
*)                     this program performs the same function
*)                     reliably ... everytime.
*  Calling Samples...: =CDToParentDirectory()
*  Parameter List....: None
*  Major change list.:
FUNCTION CDToParentDirectory(tcProgram)
	LOCAL lcCurDir, lcNewDir
	lcCurDir = CURDIR()
	lcNewDir = IIF(OCCURS("\", lcCurDir) <= 2, "\", SUBSTR(lcCurDir,1,RAT("\", lcCurDir, 2) -1))
	
	CD (lcNewDir)
	
	RETURN
ENDFUNC


************************************************************
*  FUNCTION ConvertValueToCharacter()
************************************************************
*  Author............:
*  Project...........:
*  Created...........:
*  Copyright.........:
*) Description.......:
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION ConvertValueToCharacter()
	LPARAMETERS tuValue, tcRetVal

	LOCAL llRetVal
	llRetVal = .T.

	DO CASE
		CASE TYPE("tuValue") = "C"
			tcRetVal = tuValue

		CASE TYPE("tuValue") = "D"
			tcRetVal = DTOC(tuValue)

		CASE TYPE("tuValue") = "N"
			tcRetVal = ALLTRIM(STR(tuValue))

		CASE TYPE("tuValue") = "T"
			tcRetVal = TTOC(tuValue)

		CASE TYPE("tuValue") = "Y"
			tcRetVal = ALLTRIM(STR(tuValue))

		CASE TYPE("tuValue") = "L"
			IF tuValue
				tcRetVal = "T"
			ELSE
				tcRetVal = "F"
			ENDIF

		CASE TYPE("tuValue") = "M"
			tcRetVal = ""

		CASE TYPE("tuValue") = "O"
			tcRetVal = ""

		CASE TYPE("tuValue") = "G"
			tcRetVal = ""

		CASE TYPE("tuValue") = "U"
			tcRetVal = ""

		OTHERWISE
			llRetVal = .F.
			tcRetVal = "Unknown Value"
	ENDCASE

	RETURN llRetVal
ENDFUNC


FUNCTION GetFieldName(tcCursorDotFieldName, tcFieldName, toContainedControl)
	LOCAL lnDotLocation, lnFieldStartPosition, llRetVal

	lnDotLocation = AT(".",tcCursorDotFieldName)
	IF lnDotLocation = 0
		tcFieldName = tcCursorDotFieldName
	ELSE
		lnFieldStartPosition = lnDotLocation + 1
		tcFieldName = ALLTRIM(SUBSTR(tcCursorDotFieldName, lnFieldStartPosition))
	ENDIF

	llRetVal = TYPE("tcFieldName") == "C" AND NOT EMPTY(tcFieldName)

	IF llRetVal
		IF TYPE("toContainedControl.cAlias") == "C"
			llRetVal = TYPE(toContainedControl.cAlias+"."+tcFieldName) # "U"
		ELSE
			llRetVal = TYPE(tcFieldName) # "U"
		ENDIF
	ENDIF

	RETURN llRetVal
ENDFUNC


FUNCTION GenerateDistinctFileName(tcAlias, tcFileExtension)
	IF TYPE("tcFileExtension") # "C"
		tcFileExtension = ""
	ELSE
		tcFileExtension = "." + tcFileExtension
	ENDIF

	tcAlias = "TM" + RIGHT(SYS(3), 6)

	DO WHILE FILE(tcAlias + tcFileExtension)
		tcAlias = "TM" + RIGHT(SYS(3), 6)
	ENDDO
	
	RETURN
ENDFUNC


FUNCTION ActivatePageFrame(toObject)
	LOCAL loPage, llRetVal, lcPageCaption, lnPageNumber
	llRetVal = .T.

	DO CASE
		CASE TYPE("toObject.Parent.Name") == "C" AND ;
				ALLTRIM(UPPER(toObject.Parent.BaseClass)) = "PAGE"
			*-- A Control was placed directly onto the page frame
			*-- and not contained within a business object
			loPage = toObject.Parent

		CASE TYPE("toObject.Parent.Parent.Name") == "C" AND ;
				ALLTRIM(UPPER(toObject.Parent.Parent.BaseClass)) = "PAGE"
			*-- The SAVIContainedControl is a member of a business object which
			*-- was, in turn, placed on a page in a page frame
			loPage = toObject.Parent.Parent

		OTHERWISE
			*-- No page frame exists ... so do not try and activate it
			llRetVal = .F.

	ENDCASE

	IF llRetVal
		lcPageCaption = loPage.Caption
		lnPageNumber = loPage.Parent.GetPageNumber(lcPageCaption)
		loPage.Parent.ActivePage = lnPageNumber
	ENDIF

	RETURN llRetVal
ENDFUNC


*  FUNCTION eCompObj()
*  Author............: Ed Leafe
*  Project...........: Visual Codebook Framework
*  Created...........: 08/14/97
*  Copyright.........: (c)1997-8 Ed Leafe
*) Description.......: Since the COMPOBJ() function which ships with VFP has some holes
*)                   : in it, this function was written to truly determine if object
*)                   : references are actually identical.
*)                   : NOTE: Updated for VFP 6's ability to directly compare objects.
*  Calling Samples...: IF eCompObj(loObjectRef, loSomeOtherRef)
*  Parameter List....: toObj1, toObj2: object references
*  Major change list.:
FUNCTION eCompObj(toObj1, toObj2)
	LOCAL lcComment1, lcComment2, llRetVal

	IF VERSION() = "Visual FoxPro 05."

		* Save the original comments (who knows, they might be important!)
		lcComment1 = toObj1.Comment
		lcComment2 = toObj2.Comment

		* Set the comments to something different. If they are the same object,
		* they will still have the same comment afterwards.
		toObj1.Comment = "111"
		toObj2.Comment = "222"

		llRetVal = (toObj2.Comment == toObj1.Comment)

		* Restore the original comments.
		toObj1.Comment = lcComment1
		toObj2.Comment = lcComment2

	ELSE

		* Version 6 or later; can simply compare the objects.
		llRetVal = (toObj1 = toObj2)

	ENDIF

	RETURN llRetVal
ENDFUNC


************************************************************
*  FUNCTION CreateHook()
************************************************************
*  Author............:	CT Blankenship
*  Project...........:	Visual Codebook Framework
*  Created...........:	10/08/98
*  Copyright.........:	(c)1998 Flash Creative Management, Inc.
*) Description.......:	This method takes on the responsibility
*)						of creating the hook for any object. Now,
*)						instead copying and pasting this code
*)						into each object requiring the creation
*)						of a hook, you can call this method and
*)						pass a reference to the object having the
*)						hook created.
*  Calling Samples...: =CreateHook(THIS)
*  Parameter List....: toObject - reference to object being hooked
*  Major change list.:
FUNCTION CreateHook(toObject)
	LOCAL lnCommaPOS, lcFirstHook, lcRemainingHooks
	lnCommaPOS = AT(",", toObject.cHook)

	IF lnCommaPOS > 0
		lcFirstHook = LEFT(toObject.cHook, lnCommaPOS - 1)
		lcRemainingHooks = SUBSTR(toObject.cHook, lnCommaPOS + 1)
	ELSE
		lcFirstHook = ALLTRIM(toObject.cHook)
		lcRemainingHooks = ""
	ENDIF

	toObject.oHook = CREATEOBJ(lcFirstHook)

	IF TYPE("toObject.oHook.Name") == "C" AND NOT EMPTY(lcRemainingHooks)
		toObject.oHook.DoHook("AddMultipleHooks", lcRemainingHooks)
	ENDIF
	
	RETURN
ENDFUNC

FUNCTION TrimPath()
	LPARAMETERS tcFileName, tlTrimExt, tlPlatType
	PRIVATE lnPos

	IF EMPTY(tcFileName)
		RETURN ""
	ENDIF
	
	lnPos=AT(":", tcFileName)
	IF lnPos>0
		tcFileName = SUBSTR(tcFileName, lnPos+1)
	ENDIF
	
	IF tlTrimExt
		tcFileName = TrimExt(tcFileName)
	ENDIF
	
	IF tlPlatType
		tcFileName = IIF(_DOS OR _UNIX, UPPER(tcFileName), LOWER(tcFileName))
	ENDIF
	
	tcFileName = ALLTRIM(SUBSTR(tcFileName, AT("\", tcFileName, ;
		MAX(OCCURS("\", tcFileName), 1)) + 1))
		
	DO WHILE LEFT(tcFileName, 1) == "."
		tcFileName = ALLTRIM(SUBSTR(tcFileName, 2))
	ENDDO
	
	DO WHILE RIGHT(tcFileName, 1) == "."
		tcFileName = ALLTRIM(LEFT(tcFileName, LEN(tcFileName)- 1))
	ENDDO
	
	RETURN tcFileName
ENDFUNC


FUNCTION TrimExt()
	LPARAMETERS tcFileName
	LOCAL lcRetVal, lnLastDot
	
	lcRetVal = tcFileName
	lnLastDot = RAT(".", tcFileName)
	IF lnLastDot > 0
		lcRetVal = LEFT(tcFileName, lnLastDot - 1)
	ENDIF
	
	RETURN lcRetVal
ENDFUNC


FUNCTION AddBs(tcString)
	LOCAL lcString
	lcString= tcString

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

	RETURN lcString
ENDFUNC