home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / GELLER.ZIP / EXAMPLE.PRG next >
Encoding:
Text File  |  1990-06-02  |  12.7 KB  |  570 lines
  1. *  Program.......: EXAMPLE.PRG
  2. *  Author........: Barbara Geller
  3. *  Date..........: 06/01/90
  4. *  Description...: Examples
  5. *  Notice........: 1990 Clipper Developers Conference
  6.  
  7. #include "j:\beta\inkey.ch" 
  8. #include "j:\beta\setcurs.ch" 
  9. #include "j:\beta\achoice.ch"
  10.  
  11. #define MY_HSEP      "═╤═"
  12. #define MY_CSEP      " │ " 
  13. #define MY_FSEP      "═╧═" 
  14.  
  15. #define MY_CSEP2     " ║ "
  16. #define MY_HSEP2     "═╦═"
  17. #define MY_FSEP2     "═╩═" 
  18.  
  19. PARAMETERS shade 
  20.  
  21. IF TYPE('shade') == "U"
  22.    shade := "color"
  23. ENDIF 
  24.  
  25. INITS()
  26. PAINT(co_norm) 
  27.  
  28. DO WHILE .t.
  29.    clear
  30.  
  31.    @ 0, 1 to 23,78 double
  32.    CENTER_SH(2,"CLIPPER 5.0  -  DEVCON 1990",1,5,3,74,4)
  33.  
  34.    CENTER_SH(0,"",6,17,14,62,4)
  35.    CENTER(17,'Enter Selection . . .')
  36.  
  37.    PAINT(co_detail) 
  38.  
  39.    @  8,35 prompt "Achoice      "  
  40.    @  9,35 prompt "Get System   "  
  41.    @ 10,35 prompt "Browse DBF   "  
  42.    @ 11,35 prompt "Browse ARRAY "  
  43.    @ 12,35 prompt "Exit Program "  
  44.    menu TO choice
  45.  
  46.    PAINT(pop) 
  47.  
  48.    DO CASE
  49.       CASE choice == 1
  50.          EX_ACH()
  51.  
  52.       CASE choice == 2
  53.          EX_GET()
  54.  
  55.       CASE choice == 3
  56.          EX_BROW1()
  57.  
  58.       CASE choice == 4
  59.          EX_BROW2()
  60.  
  61.       CASE choice == 0 .or. choice == 5
  62.          exit
  63.    ENDCASE
  64. ENDDO 
  65.  
  66. SETCURSOR(.t.)
  67. close all 
  68. clear
  69. quit
  70.  
  71. * EOF : EXAMPLE.PRG 
  72.  
  73. *******************************************
  74. *******************************************
  75.  
  76. FUNCTION ex_ach      
  77.    clear 
  78.  
  79.    PAINT(co_banner)
  80.    CENTER_SH(2,"ACHOICE EXAMPLE",1,20,3,59,4)
  81.    PAINT(pop)
  82.  
  83.    m->date     := DATE() 
  84.    m->position := "PROGRAMMER"
  85.    m->degree   := "None "
  86.  
  87.    @ 7,28 say "Hire Date :" 
  88.    @ 8,28 say "Job Title :" 
  89.    @ 9,28 say "Qualified :"
  90.  
  91.    CENTER(23,"<ESC> to Abort")
  92.  
  93.    DO WHILE .t.
  94.       @ 7,42 get m->date                      
  95.       @ 8,42 get m->position              WHEN ACH_POSIT(8,28,"Job Title :")  
  96.       @ 9,42 get m->degree    PICTURE "!"    
  97.  
  98.       READC() 
  99.  
  100.       IF LASTKEY() == 27 
  101.          exit
  102.       ENDIF
  103.    ENDDO
  104.  
  105.    return .t. 
  106. * EOF : achoice example 
  107.  
  108. FUNCTION ach_posit(trow,tcol,tmsg) 
  109.    LOCAL start 
  110.    PRIVATE readv
  111.  
  112.    readv := READVAR() 
  113.    lastk := LASTKEY()  
  114.  
  115.    * track array name for achoice UDF 
  116.    ach_array := "ach_posit"         
  117.  
  118.    PAINT(co_invwind) 
  119.    @ trow,tcol say tmsg
  120.    PAINT(pop) 
  121.  
  122.    PAINT(co_wind) 
  123.    PCLR("pbuff",6,9,arr_bott+1,22,4) 
  124.    @ 6,14 say 'JOB ' 
  125.  
  126.    start := ASCAN(ach_posit,&readv)              
  127.    ans   := ACHOICE(7,11,arr_bott,20,ach_posit,.t.,"a_udf",start) 
  128.    PAINT(pop) 
  129.  
  130.    IF ans > 0  
  131.       m->position := SUBSTR(ach_posit[ans],1,10) 
  132.    ENDIF 
  133.  
  134.    RESTSCREEN(6,9,arr_bott+1,22,pbuff) 
  135.    @ trow,tcol say tmsg
  136.    keyboard CHR(lastk)
  137.  
  138.    return .t.
  139. * endfunc 
  140.  
  141. FUNCTION  a_udf
  142.    PARAMETER mode, elem_posit, rel_posit 
  143.    PRIVATE retval, lastk 
  144.  
  145.    retval := AC_CONT                         && continue
  146.    lastk  := LASTKEY() 
  147.  
  148.    DO CASE
  149.       CASE mode == AC_IDLE                   && idle 
  150.          * comes here after processing all non-keyboard exception keys 
  151.  
  152.       CASE mode == AC_HITTOP                 && up arrow past top of list 
  153.          * wrap to the bottom of the list 
  154.          PCLR("ebuff",20,30,21,75,1)
  155.  
  156.          PAINT(co_err) 
  157.          @ 20,30 say "User cursored past the first item on the list." 
  158.          @ 21,30 say "       Press any key to continue . . .        " 
  159.          INKEY(0)
  160.  
  161.          PAINT(pop) 
  162.          RESTSCREEN(20,30,21,75,ebuff)
  163.  
  164.          KEYBOARD CHR(K_CTRL_PGDN)           && Ctrl Pg Dn 
  165.  
  166.       CASE mode == AC_HITBOTTOM              && down arrow past bottom of list 
  167.          PCLR("ebuff",20,30,21,74,1)
  168.  
  169.          PAINT(co_err) 
  170.          @ 20,30 say "User cursored past the last item on the list." 
  171.          @ 21,30 say "       Press any key to continue . . .       " 
  172.          INKEY(0)
  173.  
  174.          PAINT(pop) 
  175.          RESTSCREEN(20,30,21,74,ebuff)
  176.  
  177.       CASE mode == AC_EXCEPT                 && keystroke exception 
  178.          DO CASE 
  179.             CASE lastk == K_ENTER            
  180.                retval := AC_SELECT
  181.  
  182.             CASE lastk == K_ESC 
  183.                retval := AC_ABORT            && abort
  184.             
  185.             OTHERWISE 
  186.                IF ASCAN(&ach_array,UPPER(CHR(lastk))) > 0  
  187.                   * add next line in if you want to select item 
  188. *                 keyboard chr(K_ENTER)    
  189.                   retval := AC_GOTO  
  190.                ENDIF
  191.  
  192.          ENDCASE
  193.    ENDCASE
  194.  
  195.    return retval 
  196. * endfunc 
  197.  
  198. *******************************************
  199. *******************************************
  200.  
  201. FUNCTION ex_get
  202.    PUBLIC dog := "This is the First Get to Test"
  203.  
  204.    clear 
  205.  
  206.    PAINT(co_banner)
  207.    CENTER_SH(2,"GET LIST EXAMPLE",1,20,3,59,4)
  208.    PAINT(pop)
  209.  
  210.    DO WHILE LASTKEY() # K_ESC 
  211.       @ 8,15 get dog VALID udf_a()
  212.       READC()
  213.    ENDDO
  214.  
  215.    return .t.
  216. * endfunc 
  217.  
  218. FUNCTION udf_a
  219.    LOCAL   dog := "Welcome to DevCon 1990" 
  220.    PRIVATE getList := {}, tiger := "This is the third Get list."
  221.  
  222.    @ 12,15 GET dog
  223.    @ 14,15 GET tiger
  224.    READC()
  225.  
  226.    return .t.
  227. * endfunc 
  228.  
  229. *******************************************
  230. *******************************************
  231.  
  232. FUNCTION ex_brow1
  233.    clear 
  234.  
  235.    PAINT(co_banner)
  236.    CENTER_SH(2,"TBROWSE EXAMPLE #1",1,20,3,59,4)
  237.    PAINT(pop)
  238.  
  239.    USE test NEW
  240.  
  241.    TEST_BR1(8,11,18,68)         
  242.  
  243.    USE
  244.    SETCOLOR(co_norm)       // temp fix
  245.  
  246.    return NIL
  247. * endfunc 
  248.  
  249. FUNCTION test_br1(t,l,b,r)
  250.    LOCAL browse, column, lastk, done := .f. 
  251.  
  252.    /* make a new browse object */
  253.    browse := TBrowseDB(t+1, l+1, b, r-1)
  254.  
  255.    /* default heading and column separators */
  256.    browse:headSep := MY_HSEP
  257.    browse:colSep  := MY_CSEP
  258.    browse:footSep := MY_FSEP
  259.  
  260.    /* specify colors     1    2     3     4     5     6    7  */
  261.    browse:colorSpec := "N/W, B/W, B/BG, GR+/W, B/BG, R/W, BG/R"
  262.  
  263.    /* make a new column <1> */
  264.    column := TBColumnNew("        Name", {|| TRIM(fname) + " " + TRIM(lname) } )
  265.    column:defColor := {2, 3}
  266.    column:width    := 20
  267.    column:cargo    := "name"
  268.    browse:addColumn(column)
  269.  
  270.    /* make a new column <2> */
  271.    column := TBColumnNew("Score 1", {|x| if(x == NIL, test->score_1, test->score_1 := x) } )
  272.    column:headSep    := MY_HSEP2
  273.    column:colSep     := MY_CSEP2
  274.    column:footSep    := MY_FSEP2
  275.    column:colorBlock := {|x| if( x < 0, {6, 7}, {4, 5} )}
  276.    browse:addColumn(column)
  277.  
  278.    /* make a new column <3> */
  279.    column := TBColumnNew("Score 2", {|x| if(x == NIL, test->score_2, test->score_2 := x) } )
  280.    column:colorBlock := {|x| if( x < 0, {6, 7}, {4, 5} )}
  281.    browse:addColumn(column)
  282.  
  283.    /* make a new column <4> */
  284.    column := TBColumnNew("Rating", {|score_1, score_2| RATE_IT(test->score_1 + test->score_2) } )
  285.    column:colorBlock := {|score_1, score_2| if( (test->score_1 + test->score_2) <= 0, {6, 5}, {4, 5} )}
  286.    column:width      := 12
  287.    column:cargo      := "rating"
  288.    browse:addColumn(column)
  289.  
  290.    PAINT("N/W")
  291.    @ t, l, b, r BOX "╒═╕│╛═╘│"
  292.    PAINT(pop)
  293.  
  294.    WHILE ( ! done )
  295.  
  296.       /* stabilize the display */
  297.       WHILE ( ! browse:STABILIZE() )
  298.          lastk := INKEY()
  299.  
  300.          IF ( lastk != 0 )
  301.             exit          /* (abort if a key is waiting) */
  302.          ENDIF
  303.       ENDDO
  304.  
  305.       IF ( browse:stable )
  306.          lastk := INKEY(0)
  307.       ENDIF
  308.  
  309.       /* process key */
  310.       DO CASE
  311.  
  312.          CASE ( lastk == K_DOWN )
  313.             browse:DOWN()
  314.  
  315.          CASE ( lastk == K_UP )
  316.             browse:UP()
  317.  
  318.          CASE ( lastk == K_PGDN )
  319.             browse:PAGEDOWN()
  320.  
  321.          CASE ( lastk == K_PGUP )
  322.             browse:PAGEUP()
  323.  
  324.          CASE ( lastk == K_RIGHT )
  325.             browse:RIGHT()
  326.  
  327.          CASE ( lastk == K_LEFT )
  328.             browse:LEFT()
  329.  
  330.          CASE ( lastk == K_HOME )
  331.             browse:HOME()
  332.  
  333.          CASE ( lastk == K_END )
  334.             browse:END()
  335.  
  336.          CASE ( lastk == K_ESC )
  337.             done := .t.
  338.  
  339.          CASE ( lastk == K_RETURN )
  340.  
  341.            /* don't allow editing of first or last column */
  342.            column:= browse:GetColumn(browse:colPos)
  343.  
  344.            IF ( column:cargo == "name" .or. column:cargo == "rating")
  345.               loop
  346.            ELSE
  347.               GET_IT(browse)
  348.            ENDIF
  349.  
  350.       ENDCASE
  351.  
  352.    ENDDO
  353.  
  354.    return .t.
  355. * endfunc
  356.  
  357. FUNCTION get_it(bget)
  358.    LOCAL old_ins, column, get
  359.  
  360.    /* make sure browse is stable */
  361.    WHILE ( ! bget:STABILIZE() ) 
  362.       *
  363.    ENDDO
  364.  
  365.    /* save state */
  366.    old_ins := SETKEY(K_INS)
  367.  
  368.    /* set insert key to toggle insert mode and cursor */
  369.    SETKEY(K_INS,;
  370.      {|| SetCursor(if(ReadInsert(!READINSERT()), SC_NORMAL, SC_INSERT))})
  371.  
  372.    /* initial cursor setting */
  373.    SetCursor( if(READINSERT(), SC_INSERT, SC_NORMAL) )
  374.  
  375.    /* get column object from browse */
  376.    column := bget:GETCOLUMN(bget:colPos)
  377.  
  378.    /* create a corresponding GET */
  379.    get := GetNew(ROW(), COL(), column:block, column:heading, ,"N/W,N/BG")
  380.  
  381.    /* read it  */
  382.    ReadModal( {get} )
  383.   
  384.    /* restore state */
  385.    SetCursor(0)
  386.    SetKey(K_INS, old_ins)
  387.  
  388.    /* force redisplay of current row */
  389.    bget:refreshCurrent()
  390.  
  391.    return NIL
  392. * endfunc
  393.  
  394. FUNCTION rate_it(score)
  395.    LOCAL msg := "AVERAGE"
  396.  
  397.    IF score <= 0 
  398.      msg := "UNACCEPTABLE"   
  399.  
  400.    ELSEIF score > 100 
  401.      msg := "GREAT"   
  402.  
  403.    ENDIF
  404.  
  405.    return msg
  406. * endfunc
  407.  
  408. *******************************************
  409. *******************************************
  410.  
  411. FUNCTION ex_brow2
  412.    clear 
  413.  
  414.    PUBLIC big_array := { {"chicken", "fish", "turkey", "sushi" },;
  415.                          {"wine", "beer", "water", "plum wine" }, ;
  416.                          { "apple pie", "carrot cake", "ice cream", "cookies" } }
  417.  
  418.    PAINT(co_banner)
  419.    CENTER_SH(2,"TBROWSE EXAMPLE #2",1,20,3,59,4)
  420.    PAINT(pop)
  421.  
  422.    TEST_BR2(8,11,18,68)
  423.  
  424.    SETCOLOR(co_norm) 
  425.  
  426.    return NIL
  427. * endfunc 
  428.  
  429. FUNCTION test_br2(t,l,b,r)
  430.    LOCAL browse, column, lastk, done := .f. , index := 1
  431.  
  432.    /* make a new browse object */
  433.    browse := TBrowseDB(t+1, l+1, b, r-1)
  434.  
  435.    /* default heading and column separators */
  436.    browse:headSep := MY_HSEP
  437.    browse:colSep  := MY_CSEP
  438.    browse:footSep := MY_FSEP
  439.  
  440.    /* define top and bottom */
  441.    browse:gotopblock    := { || index := 1 }
  442.    browse:gobottomblock := { || index := LEN(big_array) }
  443.  
  444.    /* add custom 'skip UDF' */
  445.    browse:skipBlock := {|x| Skip_it(x,@index)}
  446.  
  447.    /* specify colors     1    2     3     4     5     6    7  */
  448.    browse:colorSpec := "N/W, B/W, B/BG, GR+/W, B/BG, R/W, BG/R"
  449.  
  450.    /* make a new column <1> */
  451.    column := TBColumnNew("Main Course",;
  452.      {|x| if(x == NIL, big_array[1,index], big_array[1,index]:= x) } )
  453.  
  454.    column:defColor := {2, 3}
  455.    column:width    := 10
  456.    browse:addColumn(column)
  457.  
  458.    /* make a new column <2> */
  459.    column := TBColumnNew("Drinks",; 
  460.      {|x| if(x == NIL, big_array[2,index], big_array[2,index]:= x) } )
  461.  
  462.    column:defColor := {2, 3}
  463.    column:width    := 10
  464.    browse:addColumn(column)
  465.  
  466.    /* make a new column <3> */
  467.    column := TBColumnNew("  Desserts",; 
  468.      {|x| if(x == NIL, big_array[3,index], big_array[3,index]:= x) } )
  469.  
  470.    column:defColor := {2, 3}
  471.    column:width    := 15
  472.    browse:addColumn(column)
  473.  
  474.    PAINT("N/W")
  475.    @ t, l, b, r BOX "╒═╕│╛═╘│"
  476.    PAINT(pop)
  477.  
  478.    WHILE ( ! done )
  479.  
  480.       /* stabilize the display */
  481.       WHILE ( ! browse:STABILIZE() )
  482.          lastk := INKEY()
  483.  
  484.          IF ( lastk != 0 )
  485.             exit          /* (abort if a key is waiting) */
  486.          ENDIF
  487.       ENDDO
  488.  
  489.       IF ( browse:stable )
  490.          lastk := INKEY(0)
  491.       ENDIF
  492.  
  493.       /* process key */
  494.       DO CASE
  495.  
  496.          CASE ( lastk == K_DOWN )
  497.             browse:DOWN()
  498.  
  499.          CASE ( lastk == K_UP )
  500.             browse:UP()
  501.  
  502.          CASE ( lastk == K_PGDN )
  503.             browse:PAGEDOWN()
  504.  
  505.          CASE ( lastk == K_PGUP )
  506.             browse:PAGEUP()
  507.  
  508.          CASE ( lastk == K_CTRL_PGUP )
  509.             browse:GOTOP()
  510.  
  511.          CASE ( lastk == K_CTRL_PGDN )
  512.             browse:GOBOTTOM()
  513.  
  514.          CASE ( lastk == K_RIGHT )
  515.             browse:RIGHT()
  516.  
  517.          CASE ( lastk == K_LEFT )
  518.             browse:LEFT()
  519.  
  520.          CASE ( lastk == K_HOME )
  521.             browse:HOME()
  522.  
  523.          CASE ( lastk == K_END )
  524.             browse:END()
  525.  
  526.          CASE ( lastk == K_ESC )
  527.             done := .t.
  528.  
  529.          CASE ( lastk == K_RETURN )
  530.             GET_IT(browse)
  531.  
  532.       ENDCASE
  533.  
  534.    ENDDO
  535.  
  536.    return .t.
  537. * endfunc
  538.  
  539. FUNCTION skip_it(n,index)
  540.    LOCAL moved := 0, max := LEN(big_array[1])
  541.  
  542.    IF ( n >= 0)
  543.  
  544.       IF (index + n) > max  
  545.          moved := max - index
  546.          index := max
  547.  
  548.       ELSE
  549.          index += n
  550.          moved := n
  551.  
  552.       ENDIF
  553.  
  554.    ELSE
  555.  
  556.       IF (index + n) < 1
  557.          moved := 1 - index
  558.          index := 1
  559.  
  560.       ELSE
  561.          index += n
  562.          moved := n
  563.  
  564.       ENDIF
  565.  
  566.    ENDIF
  567.       
  568.    return moved
  569. * endfunc
  570.