Media Share 9/MEDIASHARE_09.ISO/progmisc/dblib201.zip/OBSOLETE.PRG

Text File | 1993-04-27 | 26KB | 634 lines

*-------------------------------------------------------------------------------
*-- Program...: OBSOLETE.PRG
*-- Programmer: Ken Mayer (CIS: 71333,1030)
*-- Date......: 02/23/1993
*-- Notes.....: The following functions are not necessary using dBASE IV, 1.5,
*--             but have been retained in the current version of the library
*--             system in order to have some compatibility with 1.1.
*-------------------------------------------------------------------------------

FUNCTION Empty
*-------------------------------------------------------------------------------
*-- Programmer..: Jerry Wightman (WIGHTMAN)
*-- Date........: ?
*-- Notes.......: Used to check whether a memory variable in dBASE contains
*--               anything, based on type of field. (Pulled from BORBBS)
*--               NOTE: In release 1.5, replace all calls to EMPTY() with
*--               the new:  ISBLANK() function. This will be faster.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Empty(<cFld>)
*-- Example.....: @5,10 say "Enter date: " get bDate;
*--                         valid required .not. empty(bDate);
*--                         error chr(7)+"** Date cannot be Empty! **"
*-- Returns.....: Logical (.t./.f.)
*-- Parameters..: cFld  =  Field/Memvar/Expression to check for "Emptiness"
*-------------------------------------------------------------------------------

    PARAMETERS cFld       && may be memory variable or database field name
    private cTalk, lReturn

    cTalk = SET("TALK")

    lReturn = .F.      &&  FALSE means:  variable is NOT empty

    do case
       case type( "cFld" ) = "C"
          if len( ltrim(rtrim( cFld )) ) = 0
             lReturn = .T.
            endif

        case type( "cFld" ) = "N" .or. type( "cFld" ) = "F"
            if cFld = 0
                lReturn = .T.
            endif

        case type( "cFld" ) = "L"
            lReturn = .F.  && Can't check logical fields

        case type( "cFld" ) = "D"
            if cFld = {}
                lReturn = .T.
            endif

        case type( "cFld" ) = "M"
            if len( cFld ) = 0
                                lReturn = .T.
            endif

        otherwise   && TYPE = "U"
            lReturn = .T.

    endcase

    set talk &cTalk

RETURN lReturn
*-- EoF: Empty()

FUNCTION NumFlds
*-------------------------------------------------------------------------------
*-- Programmer..: Bowen Moursund (CIS: 76566,1405)
*-- Date........: 07/12/1991
*-- Notes.......: Returns the number of fields in a database structure --
*--               only in the currently selected DBF
*--               NOTE: In release 1.5, replace function NUMFLDS() with
*--               FLDCOUNT() -- built in to 1.5, faster ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 07/12/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: NumFlds()
*-- Example.....: ? NumFlds()
*-- Returns.....: Number of fields
*-- Parameters..: None
*-------------------------------------------------------------------------------

    private nFlds,cFldName

    *-- If currently selected database is empty (no dbf file)
    if len(trim(dbf())) = 0
        nFlds = 0                     && set to 0
    *-- we have something ...
    else
        nFlds = 0                     && initialize
        do while .t.                  && loop through the record structure
            nFlds= nFlds + 1           && increment counter
            cFldName = field(nFlds)    && get fieldname
            if len(trim(cFldName)) = 0 && if length = 0,
                nFlds = nFlds - 1       &&   decrement counter
                exit                    &&   get out of loop, we're done
            endif                      && endif(length...)
        enddo                         && end of loop
    endif

RETURN nFlds
*-- EoF: NumFlds()

FUNCTION DateSet
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Returns string giving name of current DATE format
*--               This is not needed in Version 1.5, in which set("DATE")
*--               returns the format.  Unlike that function in 1.5, this
*--               one cannot distinguish between date formats set with
*--               different terms that amount to the same thing:
*--                     DMY = BRITISH = FRENCH
*--                     MDY = AMERICAN
*--                     YMD = JAPAN
*--               If your users will be using one of these formats and
*--               are sensitive about the name, substitute the one they
*--               want for the equivalent in this function.
*-- Rev. History: 03/01/1992 -- Original
*-- Written for.: dBASE IV, versions below 1.5
*-- Rev. History: None
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: DateSet()
*-- Example.....: ?DateSet()
*-- Returns.....: Character
*-- Parameters..: None
*-------------------------------------------------------------------------------

    private cCent, cTestdate, cDelimiter
    cCent = set( "CENTURY" )
    set century off
    cTestdate = ctod( "01/02/03" )
    cDelimiter = substr( dtoc( cTestdate ), 3, 1 )
    set century &cCent
    do case
      case month( cTestdate ) = 1
        RETURN iif( cDelimiter = "-", "USA", "MDY" )
      case day( cTestdate ) = 1
        RETURN iif( cDelimiter = "/", "DMY", ;
          iif( cDelimiter = ".", "GERMAN", "ITALIAN" ) )
      otherwise
        RETURN iif( cDelimiter = ".", "ANSI", "YMD" )
    endcase

*-- EoF: DateSet()

FUNCTION Stampval
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 04/07/1992
*-- Notes.......: Passed a 16-character string in the form of the rightmost
*--             : 16 characters returned by the DOS DIR command for a file,
*--             : returns a number that will compare properly in date/time
*--             : order with the numbers returned by this function for other
*--             : files.
*-- Written for.: dBASE IV Versions below 1.5
*-- Rev. History: 04/07/1992
*-- Calls       : None
*-- Called by...: Any
*-- Usage.......: Stampval(<cTimestamp>)
*-- Example.....: IF Stampval("02-22-92  10:54a") > Stampval("04-05-92   5:54p")
*-- Returns.....: Numeric corresponding to time stamp of file
*-- Parameters..: cStamp, a DIR timestamp
*-------------------------------------------------------------------------------
   parameters cStamp
   RETURN 1440 * ( 12 * val( left(cStamp,2)) + val(substr(cStamp,4,2)) ;
       + 372*val(substr(cStamp,7,2)) ) + 60 * val(substr(cStamp,11,2)) ;
       + val(substr(Cstamp,14,2)) + iif(right(cStamp,1)="p",720,0)
*--Eof() Stampval

PROCEDURE FullWin
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/91
*-- Notes.......: Overlays menus or another screen with a full window,
*--               so that processing is done in the window, and one can return
*--               directly to the menus, without redrawing screen and such.
*--               This routine may be a problem in dBASE IV, 1.5 ... use
*--               with caution ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do fullwin with <cColor>,<cWinName>,<cScreen>
*-- Example.....: do fullwin with "w+/b","w_Edit","sc_Main"
*--                * perform whatever actions are needed in the window
*--               deactivate window wEdit
*--               release window wEdit
*--               restore screen from sMain
*--               release screen sMain
*-- Returns.....: None
*-- Parameters..: cColor   = Colors for window
*--               cWinName = Name of window
*--               cScreen  = Name of screen
*-------------------------------------------------------------------------------

    parameters cColor,cWinName,sScreen

    define window &cWinName from 0,0 to 23,79 none color &cColor.
    save screen to &sScreen.
    activate window &cWinName.

RETURN
*-- EoP: FullWin

PROCEDURE SetColor
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*--               checks to see if a color monitor is attached (ISCOLOR()),
*--               and sets system variables, that can be used in SET COLOR OF
*--               commands. You must define the memvars as PUBLIC, see Example
*--               below -- otherwise nothing will work.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*--               program) and commented a bit more, minor modifications by
*--               Ken Mayer
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor
*-- Example.....: in a menu or setup program:
*--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*--                      cl_entry,cl_stand,cl_menu,cl_warn
*--               DO setcolor
*--                  by declaring the variables PUBLIC before calling SETCOLOR
*--                  they should be globally available throughout, unless you
*--                  use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: None
*-------------------------------------------------------------------------------

    if file("COLOR.MEM")
        restore from Color.mem additive    && if color.mem exists, restore from it
    else                                && otherwise, create it
        lC           = iscolor()             && remember -- foreground/background
        cl_Blank = "n/n,n/n,n"           && black on black on black ...
        cl_Func  = "n/w"                 && function keys (used in CLRSHOW)
            * if iscolor() = true, define color, otherwise black/white
        cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
        cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n")   && data entry fields
        cl_Error = iif(lC,"rg+/r,w/n,n"    , "w+/n,n/w,n")   && error messages
        cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
        cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
        cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
        cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
        save to color all like cl_*        && create COLOR.MEM
    endif

    *-- change current color settings to these ...
    set color to &cl_stand
    cTemp = extrclr("&cl_data")
    set color of fields   to &cTemp
    set color of messages to &cTemp
    set color of box      to &cTemp
    cTemp = extrclr("&cl_stand")
    set color of highlight to &cTemp

RETURN
*-- EoP: SetColor

PROCEDURE SetColor2
*-------------------------------------------------------------------------------
*-- Programmer..: Phil Steele
*-- Date........: 05/23/91
*-- Notes.......: Used to set the screen colors for a system. It
*--               checks a parameter passed by the programmer to see if the
*--               monitor is a color system. It then creates the proper color
*--               combinations based on this ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: Borrowed from Phil Steele's PCSDEMO (a public domain
*--               program) and commented a bit more, minor modifications by
*--               Ken Mayer 11/21/91 -- Modified for parameter ...
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: do setcolor2 with "<cYN>"
*-- Example.....: in a menu or setup program:
*--               PUBLIC cl_blank,cl_func,cl_help,cl_data,cl_error,;
*--                      cl_entry,cl_stand,cl_menu,cl_warn
*--               DO setcolor2 with "Y"
*--                  by declaring the variables PUBLIC before calling SETCOLOR
*--                  they should be globally available throughout, unless you
*--                  use a CLEAR ALL or RELEASE ALL command ...
*-- Returns.....: None
*-- Parameters..: cYN  =  "Y" for color, "N" for mono ...
*-------------------------------------------------------------------------------

    parameter cYN
    private lC, cTemp

    lC           = iif(cYN="Y",.t.,.f.)  && remember -- foreground/background
    cl_Blank = "n/n,n/n,n"           && black on black on black ...
    cl_Func  = "n/w"                 && function keys
    cl_Help  = iif(lC,"n/g,g/n,n"      , "w+/n,n/w,n")   && help
    cl_Data  = iif(lC,"rg+/gb,gb/rg,n" , "n/w,w+/n,n")   && data entry fields
    cl_Error = iif(lC,"rg+/r,w/n,n"    , "w+/n,n/w,n")   && error messages
    cl_Entry = iif(lC,"n/w,w/n,n"      , "n/w,w/n,n")    && data entry??
    cl_Stand = iif(lC,"w+/b,b/w,n"     , "w+/n,n/w,n")   && standard screen
    cl_Menu  = iif(lC,"rg+/b,b/w,n"    , "w+/n,n/w,n")   && menus
    cl_Warn  = iif(lC,"rg+/r,w/n,n"    , "w/n,n/w,n")    && warning messages
    save to color all like cl_*        && create COLOR.MEM

    *-- change current color settings to these ...
    set color to &cl_stand
    cTemp = extrclr("&cl_data")
    set color of fields   to &cTemp
    set color of messages to &cTemp
    set color of box      to &cTemp
    cTemp = extrclr("&cl_stand")
    set color of highlight to &cTemp

RETURN
*-- EoP: SetColor2

FUNCTION ExtrClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/24/1991
*-- Notes.......: Used to extract the first parameter of the MEMVARS
*--               created from SETCOLOR above. The SET COLOR OF commands can
*--               only use the first parameter.
*--               It is recommended that you run SetColor (above) first,
*--               although if you define your own color memvars, this will work
*--               just as well.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/24/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: extrclr(<cMemVar>)
*-- Example.....: set color of highlight to &extrclr(cl_stand)
*-- Returns.....: "W+/B"
*-- Parameters..: cMemVar = color memory variable to have colors extracted from
*-------------------------------------------------------------------------------

    parameters cMemVar

RETURN substr(cMemVar,1,(at(",",cMemVar)-1))
*-- EoF: ExtrClr()

FUNCTION InvClr
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 05/23/1991
*-- Notes.......: Used to set an inverse color, using value(s) returned
*--               from extrclr above, or from a single color memvar.
*--               Inverted colors may give odd results -- RG+ (yellow) is
*--               not a background color, for example, and will appear as
*--               RG (brown) -- this may not be what you wanted ...
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: 05/23/1991 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: invclr(<cMemVar>)
*-- Example.....: set color of highlight to &invclr(extrclr(cl_stand))
*--                    or
*--               x = extrclr(cl_stand)
*--               set color of highlight to &invclr(x)
*-- Returns.....: "B/W+"
*-- Parameters..: cMemVar = color variable containing colors to be inverted
*-------------------------------------------------------------------------------

    parameters cMemVar
    private cTemp1, cTemp2

        cTemp1 = substr(cMemVar,1,(at("/",cMemVar)-1))
        cTemp2 = substr(cMemVar,(at("/",cMemVar)+1),len(cMemVar))

RETURN cTemp2+"/"+cTemp1
*-- EoF: InvClr()

**********************************************************************
***** THE FOLLOWING WERE MOVED HERE FROM OTHER LIBRARY FILES FOLLOWING
***** THE RELEASE OF dBASE IV, 2.0.  KJM
**********************************************************************

FUNCTION Rat
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Reverse "at", returns position a character string is last
*--               AT in a larger string.
*-- Written for.: dBASE IV
*-- Rev. History: 03/01/1992 -- Original Release
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Rat("<cFindStr>","<cBigStr>")
*-- Example.....: ? Rat("Test","This is a Test string, with Test data")
*-- Returns.....: Numeric value
*-- Parameters..: cFindStr = string to find in cBigStr
*--               cBigStr  = string to look in
*-------------------------------------------------------------------------------

    parameters cFindstr, cBigstr
    private nPos,nLen
    nLen = len( cFindstr )
    nPos = len( cBigstr ) - nLen + 1
    do while nPos > 0
        if substr( cBigstr, nPos, nLen ) = cFindstr
            exit
        else
            nPos = nPos - 1
        endif
    enddo

RETURN max( nPos, 0 )
*-- EoF: RAt()

FUNCTION IsMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 06/18/1992
*-- Notes.......: This is used to determine the presence of a mouse driver.
*--               Returns a .t. if a mouse driver is detected, a .f. otherwise.
*--               This routine will turn the mouse off, automatically. This
*--               can be used to detect a mouse, and turn it off, as well
*--               as to set a memvar to determine the current mouse state.
*--               For example, after running this routine, the mouse will be
*--               off (if there's a driver).
*--               ******************************
*--               **** REQUIRES JPMOUSE.BIN ****
*--               ******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/18/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsMouse()
*-- Example.....: ?IsMouse()
*-- Returns.....: Logical
*-- Parameters..: None
*-------------------------------------------------------------------------------

    private cRetVal, lIsMouse, X

    Load JPMOUSE.BIN
    cRetVal = call("JPMOUSE","?")
    lIsMouse = iif(cRetVal="T",.t.,.f.)
    if lIsMouse
        x = call("JPMOUSE","H")
    endif
    release module JPMOUSE

RETURN lIsMouse
*-- EoF: IsMouse()

PROCEDURE SetMouse
*-------------------------------------------------------------------------------
*-- Programmer..: Ken Mayer (CIS: 71333,1030)
*-- Date........: 06/18/1992
*-- Notes.......: This is used to determine the presence of a mouse driver,
*--               and/or turn the mouse cursor off in dBASE IV, 1.5
*--               ******************************
*--               **** Requires JPMOUSE.BIN ****
*--               ******************************
*-- Written for.: dBASE IV, 1.5
*-- Rev. History: 06/18/1992 -- Original
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: Do SetMouse with <c_Mouse>
*-- Example.....: PUBLIC c_Mouse
*--               x=ismouse()  && function in MISC.PRG
*--               store "OFF" to c_Mouse  && after calling IsMouse() it's 'Off'
*--               ON KEY LABEL Alt-M DO SetMouse
*-- Returns.....: .T.
*-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
*--                         by this procedure to the opposite scenario when the
*--                         routine is called. The concept here is to switch
*--                         the mouse on and/or off if there's a mouse driver.
*--                This memvar should be set to the current status of the mouse-
*--                if on, it should hold "ON" in it ...
*-------------------------------------------------------------------------------

    private X

    if type("C_MOUSE") # "C"         && if c_Mouse has not been defined as
        return                        &&   a character field, return
    endif

    load JPMOUSE.BIN                && load the module

    *-- if the mouse is off, we're going to set it on ("S"), if on, we're
    *-- going to set it off "H")
    cSetMouse = iif(upper(c_Mouse) = "OFF","S","H")
    x=call("JPMOUSE",cSetMouse)

    release module JPMOUSE           && remove from memory

    *-- if c_Mouse was 'off' we are setting it 'on', and vice versa
    c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse

RETURN
*-- EoP: SetMouse

FUNCTION IsUnique
*********************************************************************
**                ** WARNING WARNING WARNING **
** Extensive testing has shown that this routine causes problems in
** dBASE IV, 1.5 and later. Use SEEK() or SEEK  instead, to determine
** uniqueness (if FOUND() and all that ...)
**********************************************************************
*-------------------------------------------------------------------------------
*-- Programmer..: Clinton L. Warren (VBCES)
*-- Date........: 04/28/1992
*-- Notes.......: Checks to see if an index key already exists in the current
*--               selected database. This function was inspired by Tom
*--               Woodward's Chk4Dup UDF.
*-- Written for.: dBASE IV, 1.1
*-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
*--               May  7, 1991 Version 1.0  Initial 'release'.
*--               04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
*--               behavior (see READ.ME that comes with 1.5). Should function
*--               fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
*--               NOTE: NEW PARAMETER
*-- Calls.......: None
*-- Called by...: Any
*-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
*-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
*--                  valid required IsUnique(SSN, "SSN", "SSN");
*--                  message "Enter a new SSN";
*--                  error chr(7)+"SSN must be unique!"
*-- Returns.....: .T./.F.
*-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
*--               cOrder = MDX Tag used to order the database. Must be set for
*--                        field being checked.
*--               cField = field name for 'get'.
*-------------------------------------------------------------------------------

    parameters xValue, cOrder, cField
    private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
    private lIsUnique

    nRecNo = recno()           && store current record number
    nRecCnt = reccount()       && count records in database

    if nRecCnt = 0             && empty database, cValue MUST be unique
       return .t.
    endif

    cSetNear = set('NEAR')     && store status of NEAR flag
    set near off               && set it off
    cSetDel = set('DELETE')    && store status of DELETE
    set delete on              && Delete must be ON for this to work
    lIsDeleted = deleted()     && is current record deleted?
    delete                     && set delete flag for current record
    cSetOrder = order()        && store current MDX tag
    set order to (cOrder)      && set tag to that sent to function

    if seek(xValue)            && does it exist already?
       lIsUnique = .f.         &&   if so, it's not unique
    else                       && otherwise,
       lIsUnique = .t.         &&   it is.
    endif

   set order to (cSetOrder)   && restore changed settings to original settings
   set delete &cSetDel
   set near &cSetNear

   if nRecNo > nRecCnt        && if called during an append
      go bottom               && goto the bottom of the database,
      skip 1                  &&   plus one record (the new one)
      if lIsUnique            && this is the new part ...
     replace &cField with xValue
      endif
   else
      go nRecNo               && otherwise, goto the current record number
   endif

   if .not. lIsDeleted        && was record 'deleted' before?
      recall                  && if not, undelete it ... (turn flag off)
   endif

RETURN (lIsUnique)
*-- EoF: IsUnique()

FUNCTION Delay
*-------------------------------------------------------------------------------
*-- Programmer..: Jay Parsons (CIS: 70160,340)
*-- Date........: 03/01/1992
*-- Notes.......: Delay Loop.  Returns .T. after lapse of given number of
*--               seconds.  Accurate to one second.  For dBASE IV 2.0, use
*--               the upgraded version in Time.prg.
*--               This may be used in conjunction with EXACTIME.BIN or a
*--               similar routine that obtains the tick count.  In that case,
*--               the delay may be made accurate to one tick.  To use it this
*--               way, add:
*--                             LOAD Exactime
*--                             Arg = space(11)
*--               and substitute for each call of the time() function:
*--                             call( "Exactime", Arg )
*--
*-- Written for.: dBASE IV, Versions below 2.0
*-- Rev. History: 03/01/1992 -- Original function
*--               04/20/1993 -- modified to deal with fractions, bug fixed
*-- Calls.......: TIME2SEC()           Function in TIME.PRG
*-- Called by...: Any
*-- Usage.......: Delay(<nSeconds>)
*-- Example.....: lX= Delay(10.25)
*-- Returns.....: Logical
*-- Parameters..: nSeconds = number of seconds to delay
*-------------------------------------------------------------------------------

        parameters nSeconds         && up to 86400, one day
        private nTimeout, nTimenow, lRollover
        nTimeout = 100 * ( Time2Sec( time() ) + nSeconds )
        if nTimeout > 8640000
          lRollover = .T.
          nTimeout = nTimeout - 8640000
        else
          lRollover = .F.
        endif
        do while .T.
          nTimenow = 100 * Time2Sec( time() )
          if nTimenow < nTimeout
            lRollover = .F.
          else
            if .not. lRollover
              exit
            endif
          endif
        enddo

RETURN .T.
*-- EoF: Delay()

*-------------------------------------------------------------------------------
*-- End of Program: OBSOLETE.PRG
*-------------------------------------------------------------------------------