Power-Programmierung/CD1.mdf/xbase/library/clipper/rlib/demoproc.prg

Text File | 1989-02-18 | 14.8 KB | 549 lines

******************************************************************************
* THIS FILE CONTAINS THE PROCEDURES WHICH ACTUALLY DEMONSTRATE THE FUNCTIONS *
******************************************************************************


*-----------------------------------------------------------------------------
PROCEDURE d_atinsay
mrow = 21
mcol = 20
mcolor = 'W+*/N   '
mtext  = '           Testing: 1, 2, 3           '
DO ClearTop
@ 3,0,11,79 BOX double
@ 5, 1 SAY 'Enter row,colum coordinates   ,'
@ 5,29 GET mrow PICTURE '##' RANGE 0,24
@ 5,32 GET mcol PICTURE '##' RANGE 0,79
@ 6, 1 SAY 'Enter Clipper color string ' GET mcolor PICTURE "@!"
@ 7, 1 SAY 'Enter the text to display  ' GET mtext  PICTURE "@K"
SET CURSOR ON
READ
SET CURSOR OFF
ATINSAY( mrow, mcol, mcolor, mtext )
CENTER( 10, 'Press any key to continue...' )
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_boxask
DO ClearTop
SET CURSOR ON
@ 3,0,11,79 BOX double
@ 5,1 SAY 'Enter two lines of text to appear in BOXASK (up to 65 characters each)'
@ 7,1 SAY 'Line #1: '
mline1 = KEYINPUT( 65, .F., .T. )
@ 8,1 SAY 'Line #2: '
mline2 = KEYINPUT( 65, .F., .T. )
answer = BOXASK( mline1, mline2, 'Now press any key...' )
BOXASK( 'You pressed the ' + answer + ' key in response to BOXASK',;
        'Press any key to continue...', 30 )
SET CURSOR OFF
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_bright
DO ClearTop
SET CURSOR ON
mcolor = PAD(SETCOLOR(),20)
@ 4,5,7,68 BOX double
@ 5,12 SAY 'Enter a Clipper color string:' GET mcolor
READ
@ 6,12 SAY 'The BRIGHT() of this color is: ' + BRIGHT(mcolor)
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_center
DO ClearTop
SET CURSOR ON
mstring = PAD('Greetings to all Clipper programmers!',78)
@ 4,0,7,79 BOX double
CENTER(5,'Enter a string to be centered')
@ 6,1 GET mstring PICTURE "@K"
READ
@ 6,1 SAY SPACE(78)
CENTER(6,ALLTRIM(mstring))
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_sayinbox
DO ClearTop
SET CURSOR ON
@ 3,0,11,79 BOX double
@ 5,1 SAY 'Enter three lines of text to appear in SAYINBOX (up to 65 characters each)'
@ 7,1 SAY 'Line #1: '
mline1 = KEYINPUT( 65, .F., .T. )
@ 8,1 SAY 'Line #2: '
mline2 = KEYINPUT( 65, .F., .T. )
@ 9,1 SAY 'Line #3: '
mline3 = KEYINPUT( 65, .F., .T. )
SAYINBOX( mline1, mline2, mline3, 10 )
SET CURSOR OFF
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_filedate
DO ClearTop
SET CURSOR ON
mfile = PAD(GETE('COMSPEC'),40)
@ 4,0,7,79 BOX double
CENTER(5,'Enter an existing filename:')
@ 6,CENTER(mfile) GET mfile PICTURE "@!K"
READ
@ 6,1 SAY SPACE(78)
mfile = ALLTRIM(mfile)
CENTER(6, 'Last update date of &mfile is: ' + DTOC(FILEDATE(mfile)) )
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_files
DO ClearTop
SET CURSOR ON
mfile1 = PAD('RLIB.LIB',60)
mfile2 = PAD('DEMO.EXE',60)
mfile3 = PAD('DEMO.PRG',60)
@ 4,0,7,79 BOX double
CENTER(5,"Enter files to test for existance:")
@ 6, 2 SAY "#1:" GET mfile1 PICTURE "@!KS20"
@ 6,28 SAY "#2:" GET mfile2 PICTURE "@!KS20"
@ 6,54 SAY "#3:" GET mfile3 PICTURE "@!KS20"
READ
@ 6,1 SAY SPACE(78)
mfile1 = ALLTRIM(mfile1)
mfile2 = ALLTRIM(mfile2)
mfile3 = ALLTRIM(mfile3)
mdisplay = 'FILES("&mfile1", "&mfile2", "&mfile3") = ' +;
            IF( FILES(mfile1, mfile2, mfile3), '.T.', '.F.' )
CENTER(6,mdisplay)
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_filetime
DO ClearTop
SET CURSOR ON
mfile = PAD(GETE('COMSPEC'),40)
@ 4,0,7,79 BOX double
CENTER(5,'Enter an existing filename:')
@ 6,CENTER(mfile) GET mfile PICTURE "@!K"
READ
@ 6,1 SAY SPACE(78)
mfile = ALLTRIM(mfile)
CENTER(6, 'Last update time of &mfile is: ' + FILETIME(mfile) )
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_parent
PRIVATE mdir
DO ClearTop
SET CURSOR ON
mdir = PAD('C:\CLIPPER\LIBS\RLIB\SOURCE',40)
@ 4,0,8,79 BOX double
CENTER(5, 'Press ENTER or type in another directory name:')
@ 6,CENTER(mdir) GET mdir PICTURE "@!K"
READ
@ 6,1 SAY SPACE(78)
CENTER(6,ALLTRIM(mdir))
CENTER(7,'The parent directory is ' + PARENT(mdir) )
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_pathto
PRIVATE mfile, mpath
DO ClearTop
SET CURSOR ON
mfile = "CLIPPER.EXE "
@ 4,0,8,79 BOX double
CENTER(5, 'Enter the name of a file which can be found through the DOS path')
CENTER(6, '(Current DOS path is ' + GETE('PATH') + ')')
@ 7,CENTER(mfile) GET mfile PICTURE "@!"
READ
mfile = ALLTRIM(mfile)
mpath = PATHTO(mfile)
IF EMPTY(mpath)
   CENTER(7,'&mfile is not located in any directory in the DOS path!')
ELSE
   CENTER(7,'&mfile can be found in the &mpath directory')
ENDIF
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_pickfile
DO ClearTop
@ 5,15,7,65 BOX double
filespec = '*.*' + SPACE(60)
@ 6,19 SAY 'Enter filespec:' GET filespec PICTURE '@!KS26'
SET CURSOR ON
READ
SET CURSOR OFF
@ 5,15,7,65 BOX single
IF LASTKEY() <> 27
   filename = PICKFILE( TRIM(filespec), 1, 0, 24, democolor, .T. )
   IF .NOT. EMPTY(filename)
      SAYINBOX('You selected &filename',5)
   ENDIF
ENDIF
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_decrypted
PRIVATE mstring, estring, dstring
DO ClearTop
SET CURSOR ON
mstring = SPACE(35)
@ 4,0,8,79 BOX double
@ 5,6 SAY 'Enter a string to be encrypted:' GET mstring
READ
estring = ENCRYPTED(ALLTRIM(mstring))
CENTER(6,'Encrypted version is: &estring')
dstring = DECRYPTED(estring)
CENTER(7,'Decrypted version is: &dstring')
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_encrypted
PRIVATE mstring, estring
DO ClearTop
SET CURSOR ON
mstring = SPACE(35)
@ 4,0,7,79 BOX double
@ 5,6 SAY 'Enter a string to be encrypted:' GET mstring
READ
estring = ENCRYPTED(ALLTRIM(mstring))
CENTER(6,'Encrypted version is: &estring')
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_getparm
PRIVATE mstring, mnumber, mparm
DO ClearTop
SET CURSOR ON
mstring = 'Red, Orange, Yellow, Green, Blue, Indigo, Violet'
@ 4,0,9,79 BOX double
CENTER(5,'Enter a string with sections separated by commas')
@ 6,CENTER(mstring) GET mstring PICTURE '@K'
READ
mnumber = 4
@ 7,25 SAY 'Enter parameter to retrieve:' GET mnumber PICTURE '#'
READ
mparm = GETPARM(mnumber,mstring)
CENTER(8, 'Parameter #' + STR(mnumber,1,0) + ' is: &mparm')
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_keyinput
PRIVATE length, upcase, echoon, mstring
length = 60
upcase = .F.
echoon = .T.
DO ClearTop
@ 3,0,11,79 BOX double
@ 4,2 SAY 'Enter maximum allowed key input length: ' GET length PICTURE '###'
@ 5,2 SAY 'Force characters into upper case? (Y/N):' GET upcase PICTURE 'Y'
@ 6,2 SAY 'Echo characters onto the screen? (Y/N): ' GET echoon PICTURE 'Y'
SET CURSOR ON
READ
@ 8,1 SAY 'Start typing:'
mstring = KEYINPUT(length,upcase,echoon)
@ 10,1 SAY 'You entered: ' + mstring
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_namesplit
PRIVATE mname, sname
DO ClearTop
SET CURSOR ON
mname = PAD('Elmer Q. Fudd',35)
@ 4,0,7,79 BOX double
@ 5,6 SAY 'Enter a name to be parsed (split):' GET mname
READ
sname = NAMESPLIT(mname)
CENTER(6,'NAMESPLIT() version is: &sname')
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_rjustify
PRIVATE mstring
DO ClearTop
SET CURSOR ON
mstring = SPACE(40)
@ 4,0,7,79 BOX double
@ 5,3 SAY 'Enter text to be right justified:' GET mstring
READ
@ 6,39 SAY RJUSTIFY(mstring)
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_changed
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_closearea
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_forget
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_markrec

GO TOP
DO ClearTop

@ 4,4,8,46 BOX single
@ 5,6 SAY 'Press the  keys to choose a function.'
@ 6,6 SAY 'Mark by pressing the F9 key, and finish'
@ 7,6 SAY 'by pressing the ENTER key.             '

@ 1,60,12,79 BOX double
marked = MARKREC( 2, 61, 11, 78, "' '+udf_name", -8, "udf_name" )
@ 1,60,12,79 BOX single

IF .NOT. EMPTY(marked)
   SCROLL(4,4,8,46,0)
   @ 13,0 CLEAR
   mrow = 3
   @ 3,0 SAY 'You marked: '
   DO WHILE .NOT. EMPTY(marked)
      @ mrow,12 SAY SUBSTR( marked, 1, AT(",",marked)-1 )
      marked = SUBSTR( marked, AT(",",marked)+1 )
      mrow = mrow + 1
      INKEY(1)
   ENDDO
   ?
   ? 'Press any key to continue...'
   INKEY(60)
ENDIF
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_memorize
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_mreplace
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_pickrec
PRIVATE incolor
INKEY(5)              && give them 5 more seconds to see write up on PICKREC()
GO TOP
mrow = 0
DO ClearTop
incolor = SETCOLOR()
DO WHILE .T.
   @ 1,60,12,79 BOX double
   mrow = PICKREC( 2, 61, 11, 78, "' '+udf_name", "DISPSYNTAX", dummy, mrow )
   @ 1,60,12,79 BOX single
   DO CASE
      CASE mrow = 0
         EXIT
      CASE LASTKEY() = 13                            && Enter key
         IF edit                                     && allow edits if variable set to True
            @ 13,0,24,79 BOX double
            SET COLOR TO (syntaxcolor)
            SET CURSOR ON
            REPLACE Descrip WITH MEMOEDIT( Descrip, 14, 1, 23, 78, .T. )
            SET CURSOR OFF
            SET COLOR TO (incolor)
            @ 13,0,24,79 BOX single
         ELSE
            EXIT
         ENDIF
   ENDCASE
ENDDO
RETURN


PROCEDURE dispsyntax
*-- don't update the display if they are stopming on the arrow keys
IF NEXTKEY() = 0
   SET COLOR TO (syntaxcolor)
   MEMOEDIT( Descrip, 14, 1, 23, 78, .F., .F. )
   SET COLOR TO (incolor)
ENDIF
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_alphadate
PRIVATE mdate
DO ClearTop
SET CURSOR ON
mdate = DATE()
@ 4,0,7,79 BOX double
@ 5,6 SAY 'Enter date to be displayed as text:' GET mdate
READ
CENTER(6,ALPHADATE(mdate))
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_beep
PRIVATE mnumber
DO ClearTop
SET CURSOR ON
mnumber = 2
@ 4,0,7,79 BOX double
@ 5,6 SAY 'How many times do you want to ring the bell?' GET mnumber PICTURE '#'
READ
CENTER( 6, 'This is an example of BEEP(' + STR(mnumber,1,0) + ')')
SET CURSOR OFF
BEEP(mnumber)
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_ntxkeyval
DO NoDemo
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_str2date
PRIVATE datestring
DO ClearTop
SET CURSOR ON
datestring = PAD( ALPHADATE(DATE()),30 )
@ 4,0,7,79 BOX double
@ 5,6 SAY 'Enter date string to be converted:' GET datestring
READ
CENTER( 6, "The date is: " + DTOC(STR2DATE(datestring)) )
SET CURSOR OFF
INKEY(10)
RETURN


*-----------------------------------------------------------------------------
PROCEDURE d_multimenu
SET COLOR TO (multicolors[1])
SCROLL(2,10,6,70,0)
@ 2,10,6,70 BOX single
CENTER(4,'Loading directory for MULTIMENU demostration')

*-- get a directory of all files
num = ADIR("*.*")
DECLARE files[num], sizes[num], dates[num], times[num], fileinfo[num]
ADIR( "*.*", files, sizes, dates, times )

FOR x = 1 TO num
   *-- now make each file name 12 spaces wide
   files[x] = PAD(files[x],12)
   *-- and build file description for each
   fileinfo[x] = 'Date: ' + DTOC(dates[x]) + '    ' +;
                 'Time: ' + times[x] + '    ' +;
                 'Size: ' + TRANSFORM( sizes[x], '###,###' )
NEXT x

*-- now present these files in a single line box with four
*-- columns across and descriptions on the line below the box

DO ClearTop

@ 1,0,10,79 BOX single
*-- the zero makes UDF calc column number dynamically
filenum = MULTIMENU( 2, 1, 9, 78, files, 4, fileinfo, 11, multicolors )
RETURN


*-----------------------------------------------------------------------------
* Procedure: ShowSyntax
* Notes....: Procedure to look up function in database and display the memo
*            contents in a 12 line window at the bottom of the screen.
*-----------------------------------------------------------------------------
PROCEDURE ShowSyntax
PRIVATE incolor
incolor = SETCOLOR(syntaxcolor)
@ 0,0 SAY UPPER(SUBSTR(demoproc,3)) + '()'
SCROLL(13,0,23,79,0)
@ 13,0,24,79 BOX single
SEEK UPPER(SUBSTR(demoproc,3))
MEMOEDIT( Descrip, 14, 1, 23, 78, .F., .F. )
SETCOLOR(incolor)
INKEY(showtime)
RETURN


*-----------------------------------------------------------------------------
* Procedure: ClearTop
* Notes....: Central procedure for clearing the top window in preparation
*            for the particular function demonstration.
*-----------------------------------------------------------------------------
PROCEDURE ClearTop
SCROLL(1,0,12,79,0)
RETURN


*-----------------------------------------------------------------------------
* Procedure: NoDemo
* Notes....: Sub-procedure called by several of the demo procedures.  These
*            functions by their very nature are difficult to demonstrate or
*            any demonstration would not be very meaningful.
*-----------------------------------------------------------------------------
PROCEDURE NoDemo
DO ClearTop
@ 2,6,10,72 BOX single
@ 4,8 SAY 'This function is difficult to demonstrate, as any demonstration'
@ 5,8 SAY 'would just be a reiteration of the function syntax shown below.'
@ 6,8 SAY 'See the RLIB documentation for more information and examples.'
CENTER(8,'Press any key to continue...')
INKEY(60)
RETURN