utility.prg

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

ENDFUNC


************************************************************
*  FUNCTION ARColHead()
************************************************************
*  Author............: Menachem Bazian, CPA
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:10:39
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 9. Returns a string used for column headings in
*)                   : an AR report based on tnNumDays
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION ARColHead(tnNumDays)
	LOCAL lcRetVal

	DO CASE
		CASE tnNumDays < 0
			lcRetVal = "Future "

		CASE tnNumDays <= 30
			lcRetVal = "Current"

		CASE tnNumDays <= 60
			lcRetVal = "Over30 "

		CASE tnNumDays <= 90
			lcRetVal = "Over60 "

		OTHERWISE
			lcRetVal = "Over90 "

	ENDCASE

	RETURN lcRetVal
ENDFUNC


************************************************************
*  FUNCTION ConvertToChar()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:12:08
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 10. Converts tuParam to character and returns the
*)                   : converted value
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION ConvertToChar(tuParam)
	*-- Takes a parameter of any type and converts it
	*-- a character string.
	LOCAL lcRetVal, ;
		lcType
	lcRetVal = ""
	lcType = TYPE("tuParam")
	DO CASE
		CASE lcType = "C"
			LOCAL llSQuote, llDQuote, llBracket
			llSQuote  = ['] $ tuParam
			llDQuote  = ["] $ tuParam
			llBracket = "[" $ tuParam
			DO CASE
				CASE !llSQuote
					lcRetVal = ['] + tuParam + [']
				CASE !llDQuote
					lcRetVal = ["] + tuParam + ["]
				CASE !llBracket
					lcRetVal = "[" + tuParam + "]"
				OTHERWISE
					*=ErrorMsg("Cannot create string in ConvertToChar")
					lcRetVal = ""
			ENDCASE
		CASE INLIST(lcType, "N", "B", "Y")
			lcRetVal = STR(tuParam)
		CASE lcType = "L"
			lcRetVal = IIF(tuParam, ".T.", ".F.")
		CASE lcType = "D"
			lcRetVal = DTOS(tuParam)
		CASE lcType = "T"
			lcRetVal = TTOC(tuParam)
	ENDCASE
	RETURN lcRetVal
ENDFUNC

************************************************************
*  FUNCTION IsA()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:13:29
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 11. Returns .T. if toObject is an instance of
*)                   : tcClass or one of its superclasses
*  Calling Samples...: IF IsA(Thisform, "CBizObjForm")
*  Parameter List....:
*  Major change list.:
FUNCTION IsA(toObject, tcClass)
	*-- Accepts an object and a class name as parameters.
	*-- Returns .T. if toObject was created from tcClass,
	*-- either directly or indirectly. The function is called
	*-- "IsA" since most inheritance relationships imply that
	*-- the subclass "is a" superclass, with additional properties
	*-- and/or methods. For example, if you create your own
	*-- form class, that class "is" still "a" form.

	*-- Note that we don't use the CSet object here for performance
	*-- reasons. Code in the CBar class calls this function
	*-- once for every bar, and it is much faster without having
	*-- to create a CSet object each time.

	LOCAL laClasses[1], llRetVal, lcSetExact
	lcSetExact = SET("EXACT")
	SET EXACT ON

	ACLASS(laClasses, toObject)
	llRetVal = ASCAN(laClasses, UPPER(tcClass)) > 0

	SET EXACT &lcSetExact
	RETURN llRetVal
ENDFUNC

******************************************************
*  FUNCTION IsAddingTB()
******************************************************
* Author............: Charles T. Blankenship
* Project...........: Codebook 5.0
* Created...........: 05/13/97  19:30:00
* Copyright.........: (c) Software Assets of Virginia,
*                         Inc. 1997
*) Description......: 12. The problem occurred when this function was
*)		  executed against a cursor where table buffering was activated.
*)		  The condition arose when the user added their record, repositioned
*)		  their record pointer (off of the newly added record) and then
*)		  performed an action that triggered the calling of the IsAdding()
*)		  function.  Since the record pointer was no longer positioned on
*)		  the appended record, none of the characters returned by
*)		  GETFLDSTATE() were 3s or 4s and IsAdding() erroneously
*)		  returned a .F.  I had a trouble call to fix.
*)		  This was a particularly challenging problem.  The signature
*)		  of IsAdding() could not be changed without being forced to
*)		  modify every call made to IsAdding() throughout the
*)		  framework,but this function had to be made aware of table
*)		  buffering when it was active.  The solution rested with
*)		  the creation of two new functions and the renaming of
*)		  the existing one.  The original IsAdding() code was
*)		  completely removed and placed in another function with
*)		  a new name, IsAddingOriginal().  New code was written
*)		  to perform the "Is Adding?" test on a table buffered
*)		  cursor if needed and resides in the IsAddingTB()
*)		  function - TB for Table Buffering.  Finally, a brand
*)		  new function was written but given the same name as
*)		  IsAdding().  This is what enabled me to keep the
*)		  public signature the same while adding table buffering
*)		  capability.
*)		  Listing 1:  New implementation for IsAdding()
*)		  Returns .T. if the alias
*)        specified in tcAlias is in the midst of
*)        adding a new record.  This is the same thing
*)        as  the regular IsAdding except for the fact
*)        the fact that it scans through all of the
*)        records checking for new records.  To be
*)        used when table buffering is in effect.
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:

FUNCTION IsAddingTB(tcAlias)
	LOCAL lnRecNo, lcAlias, llIsAdding
	*-- Condition the alias parameter
	IF TYPE("tcAlias") # "C" OR EMPTY(tcAlias)
		lcAlias = ALIAS()
	ELSE
		lcAlias = tcAlias
	ENDIF

	*-- Store current RP position and initialize return
	*-- value
	lnRecNo  = RECNO(lcAlias)
	llIsAdding = .F.
	GO TOP IN (lcAlias)
	*-- Scan through the alias looking for newly added
	*-- records
	DO WHILE NOT llIsAdding
		llIsAdding = IsAddingOriginal(lcAlias)
		*-- Interpret the results of the test
		IF EOF(lcAlias) OR llIsAdding
			EXIT
		ENDIF

		*-- Process the *next* record, if there is one
		IF NOT EOF(lcAlias)
			SKIP IN (lcAlias)
		ENDIF
	ENDDO

	*-- Reposition the RP to its original position, if its
	*-- safe to do so
	DO CASE
		CASE lnRecNo > RECCOUNT(lcAlias)

		CASE lnRecNo = 0

		OTHERWISE
			GO lnRecNo IN (lcAlias)

	ENDCASE

	RETURN llIsAdding
ENDFUNC


******************************************************
*  FUNCTION IsAdding()
******************************************************
* Author............: Charles T. Blankenship
* Project...........: Codebook 5.0
* Created...........: 05/13/97  19:30:00
* Copyright.........: (c) Software Assets of Virginia,
*                         Inc. 1997
*)Description.......: 13. Completely rewritten to
*)                    incorporate the additional
*)                    capability of detecting
*)                    table buffering.
* Calling Samples...:
* Parameter List....:
* Major change list.:
******************************************************
FUNCTION IsAdding(tcAlias)

	*-- Returns .T. if the user is in the midst of adding
	*-- a record to the alias specified in the tcAlias
	*-- parameter.
	LOCAL lcGetFldState, llRetVal

	DO CASE
		CASE EMPTY(tcAlias) OR !USED(tcAlias) OR ;
				(!EMPTY(tcAlias) AND CURSORGETPROP("BUFFERING",(tcAlias))=DB_BUFOFF)
			*-- If no alias was specified ... OR ...
			*-- the specified alias is not in use ... OR ...
			*-- an alias that had no table buffering active was
			*-- specified return a .F. since GETFLDSTATE()
			*-- requires buffering to be on
			llRetVal = .F.
			
		CASE CURSORGETPROP("BUFFERING",(tcAlias)) = DB_BUFOPTRECORD OR ;
				CURSORGETPROP("BUFFERING",(tcAlias)) = DB_BUFLOCKRECORD
			*-- CASE RECORD buffering is active, perform the
			*-- original functionality of IsAdding() ...
			llRetVal = IsAddingOriginal(tcAlias)

		CASE CURSORGETPROP("BUFFERING",(tcAlias)) = DB_BUFOPTTABLE OR ;
				CURSORGETPROP("BUFFERING",(tcAlias)) = DB_BUFLOCKTABLE
			*-- CASE TABLE buffering is active ...
			llRetVal = IsAddingTB(tcAlias)

		OTHERWISE
			llRetVal = .F.

	ENDCASE
	RETURN llRetVal
ENDFUNC


******************************************************
*  FUNCTION IsAddingOriginal()
******************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:14:20
*  Copyright.........: (c) Flash Creative Management,
*                          Inc., 1995
*) Description.......: 14. Returns .T. if the alias
*)                     specified in tcAlias is in the
*)                     midst of adding a new record.
*  Calling Samples...: IsAdding("Customers")
*  Parameter List....:
*  Major change list.:
******************************************************
FUNCTION IsAddingOriginal(tcAlias)
	LOCAL lcGetFldState, llRetVal

	*-- Specifying -1 causes GETFLDSTATE to return the
	*-- edit states of each field in the current record
	*-- of the specified alias ... if the record had
	*-- five fields the following return value would
	*-- mean that the record was an appended record
	*-- in the buffer, fields 1 - 3 had not been
	*-- edited or their deletion status had not been
	*-- changed and fields 4 and 5 had been edited or
	*-- their deletion status had been changed.  Either
	*-- way it proves that the buffer has had records
	*-- appended to it ... 33344; therefore, adding
	*-- is in progress ... see the expression evaluated
	*-- by the RETURN command below.
	lcGetFldState = GETFLDSTATE(-1, tcAlias)

	IF ISNULL(lcGetFldState)
		llRetVal = .F.
	ELSE
		llRetVal = (("3" $ lcGetFldState) OR ("4" $ lcGetFldState))
	ENDIF
	RETURN llRetVal
ENDFUNC


************************************************************
*  FUNCTION LockScreen()
************************************************************
*  Author............: Paul Bienick
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:16:16
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 15. Function to get around refresh anomolies
*)                   : in various situations where setting
*)                   : LockScreen to .T. while doing the refresh
*)                   : seems to help.
*  Calling Samples...: =LockScreen(.T.)
*                    : =LockScreen(.F.)
*  Parameter List....:
*  Major change list.: MODIFIED Friday, 11/28/97 14:18:43 - CTB: (#71)
************************************************************
FUNCTION LockScreen(tlValue, tlOldLockScreen)
	IF FormIsObject()
		tlOldLockScreen = _screen.ActiveForm.LockScreen
		_screen.ActiveForm.LockScreen = tlValue
	ELSE
		tlOldLockScreen = _screen.LockScreen
		_screen.LockScreen = tlValue
	ENDIF
	RETURN
ENDFUNC


************************************************************
*  FUNCTION CSZ()
************************************************************
*  Author............: Y. Alan Griver
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:17:27
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 16. This function correctly formats a city, state
*)                   : zip line. It handles 5 or 9 character zip codes.
*  Calling Samples...:
*  Parameter List....:
*  Major change list.:
FUNCTION CSZ(tcCity, tcState, tcZip)
	LOCAL lcRetVal, lcZip

	lcRetVal = ALLTRIM(tcCity)
	lcRetVal = lcRetVal + IIF(EMPTY(tcCity), " ", ", ") + tcState + " "

	IF LEN(ALLTRIM(tcZip)) = 5
		lcZip = ALLTRIM(tcZip)
	ELSE
		lcZip = LEFT(tcZip,5) + IIF(EMPTY(tcZip)," ","-") + RIGHT(tcZip,4)
	ENDIF
	
	RETURN lcRetVal + lcZip
ENDFUNC


************************************************************
*  FUNCTION YesNo()
************************************************************
*  Author............: Menachem Bazian, CPA
*  Project...........: Codebook 3.0
*  Created...........: 07/24/95  14:18:12
*  Copyright.........: (c) Flash Creative Management, Inc., 1995
*) Description.......: 17. Standard Yes/No dialog
*  Calling Samples...: IF YesNo("Isn't this neat?") = IDYES
*  Parameter List....: tcMessage:  The message to display. Defaults to
*                    :   "Are You Sure?"
*                    : tnDialogType:  The type of dialog to display.
*                    :   (only the icon. Button type designations
*                    :   are stripped out.) Defaults to a question mark icon.
*                    : tcTitleText: Text for the dialog caption.
*                    :   Defaults to the application name.
*                    : tnDefaultButton: Which button is the default.
*                    :   0 is for yes, 1 for no.
*                    : tlBeep: Beep before displaying the question?
*                    :   Defaults to yes
*  Major change list.:
FUNCTION YesNo(tcMessage, tnDialogType, tcTitleText, tnDefaultButton, tlBeep)

	IF PCOUNT() < 5 OR TYPE("tlBeep") # "L"
		tlBeep = .T.
	ENDIF

	IF TYPE("tcMessage") # "C"
		tcMessage = AREYOUSURE_LOC
	ENDIF

	IF TYPE("tnDialogType") # "N"
		tnDialogType = MB_ICONQUESTION
	ENDIF

	*-- One other thing to take care of. We need YESNO buttons on This.
	*-- If the user can define the dialog type, they may also specify
	*-- the buttons on it. Not good. The way to do this is to adjust the
	*-- value of tnDialogType to be a clean division of 16 and add MB_YESNO
	*-- to it.
	tnDialogType = tnDialogType - MOD(tnDialogType, 16) + MB_YESNO

	IF TYPE("tnDefaultButton") # "N"