home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / clipper / tbwhile / tbwhile.prg < prev   
Encoding:
Text File  |  1990-11-08  |  6.8 KB  |  281 lines
  1. ****
  2. *  TBWhile.prg
  3. *  Illustration of TBROWSE with While Condition
  4. *  Modified From TBDEMO/DBUEDIT.prgs which are:
  5. *     Copyright (c) 1990 Nantucket Corp.  All rights reserved.
  6. *
  7. *  Note:  compile with /n/w/a
  8.  
  9. * This Demo shows Names.dbf consisting of Last, First, Addr, City, State, Zip
  10. * with active index on last + first
  11. * It shows Last Name, First Name, City only for those Last Names That
  12. * Begin With Letter That You Input For The cKey GET.
  13.  
  14. * This program is entered into the public domain by James J. Orlowski, M.D.
  15. * Correction 11/7/90: added goTopBlock() and goBottomBlock() to simplify code
  16.  
  17. #include "inkey.ch"
  18. #include "setcurs.ch"
  19.  
  20. * Set Up these two MEMVARS, which track top and bottom record
  21. * for use with goTopBlock() and goBottomBlock(). They are declared as
  22. * PUBLIC in main loop
  23. MEMVAR nTopNo, nBotNo
  24.  
  25. ****
  26. *  main part of tbwhile
  27. *
  28. PROCEDURE TBWhile
  29.    LOCAL aFields := {}, aHead := {}
  30.    LOCAL cKey := "O"
  31.    MEMVAR GetList
  32.    PUBLIC nTopNo, nBotNo
  33.    * Index on Last + First
  34.    USE Names INDEX Names NEW
  35.    * Need Separate Fieldname and Alias To Use FIELDWBLOCK() function
  36.    AADD(aFields, {"Last" , "Names" })
  37.    AADD(aFields, {"First", "Names" })
  38.    AADD(aFields, {"City" , "Names" })
  39.  
  40.    AADD(aHead, "Last Name")
  41.    AADD(aHead, "First Name")
  42.    AADD(aHead, "City")
  43.    SETCOLOR("N/BG")
  44.    CLEAR SCREEN
  45.    @ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
  46.    READ
  47.    CLEAR SCREEN
  48.  
  49.    IF .NOT. TBWhileSet(cKey)  //  Passes Key to set nTopNo and nBotNo
  50.       SET COLOR TO
  51.       CLEAR SCREEN
  52.       ? "Sorry, But There Were NO Records To List"
  53.       QUIT
  54.    ENDIF
  55.    * Names->Last = cKey is the Conditional Block passed to this function
  56.    * you can make it as complicated as you want, but you would then
  57.    * have to modify TBWhileSet() to find first and last records
  58.    * matching your key.
  59.    MyBrowse(3, 6, MaxRow() - 2, MaxCol() - 6, ;
  60.             aFields, aHead, {||Names->Last = cKey} )
  61.  
  62.    SET COLOR TO
  63.    @ MaxRow(), 0 CLEAR
  64. RETURN
  65. * EOP TBWhile
  66.  
  67. ***
  68. *  MyBrowse()
  69. *
  70. FUNCTION MyBrowse(nTop, nLeft, nBottom, nRight, aFields, aHead, bWhileCond)
  71. LOCAL b, column, cType, i
  72. LOCAL cHead, cField, cAlias
  73. LOCAL cColorSave, nCursSave
  74. LOCAL lMore, nKey
  75.  
  76.    /* make new browse object */
  77.    b := TBrowseDB(nTop, nLeft, nBottom, nRight)
  78.  
  79.    /* default heading and column separators */
  80.    b:headSep := "═╤═"
  81.    b:colSep  := " │ "
  82.    b:footSep := "═╧═"
  83.  
  84.    /* add custom 'SkipWhile' (to handle passed condition) */
  85.    b:skipBlock := {|x| SkipWhile(x, bWhileCond)}
  86.  
  87.    /* Set up substitute goto top and goto bottom */
  88.    /* with While's top and bottom records        */
  89.    b:goTopBlock := {|| __dbGoto(nTopNo)}
  90.    b:goBottomBlock := {|| __dbGoto(nBotNo)}
  91.  
  92.    /* colors */
  93.    b:colorSpec := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  94.  
  95.    /* add a column for each field in the current workarea */
  96.    FOR i = 1 TO LEN(aFields)
  97.       cHead  := aHead[i]
  98.       cField := aFields[i, 1]
  99.       cAlias := aFields[i, 2]
  100.  
  101.       /* make the new column */
  102.       column := TBColumnNew( cHead, FieldWBlock(cField, Select(cAlias) ) )
  103.  
  104.       /* evaluate the block once to get the field's data type */
  105.       cType := VALTYPE( Eval(column:block) )
  106.       column:defColor := {3, 4}
  107.  
  108.       b:addColumn(column)
  109.    NEXT
  110.  
  111.    /* make a window shadow */
  112.    cColorSave := SETCOLOR("N/N")
  113.    @ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
  114.    SETCOLOR("W/W")
  115.    @ nTop, nLeft CLEAR TO nBottom, nRight
  116.    SETCOLOR(cColorSave)
  117.  
  118.    nCursSave := SetCursor(0)
  119.  
  120.    lMore := .t.
  121.    WHILE (lMore)
  122.  
  123.       /* stabilize the display */
  124.       WHILE ( .NOT. b:stabilize() )
  125.          nKey := INKEY()
  126.          IF ( nKey <> 0 )
  127.             EXIT        /* (abort IF a key is waiting) */
  128.          ENDIF
  129.       ENDDO
  130.  
  131.       IF ( b:stable )
  132.          /* display is stable */
  133.          IF ( b:hitTop .OR. b:hitBottom )
  134.             Tone(125, 0)
  135.          ENDIF
  136.  
  137.          /* everything's done; just wait for a key */
  138.          nKey := INKEY(0)
  139.       ENDIF
  140.  
  141.       /* process key */
  142.       DO CASE
  143.       CASE ( nKey == K_DOWN )
  144.          b:down()
  145.  
  146.       CASE ( nKey == K_UP )
  147.          b:up()
  148.  
  149.       CASE ( nKey == K_PGDN )
  150.          b:pageDown()
  151.  
  152.       CASE ( nKey == K_PGUP )
  153.          b:pageUp()
  154.  
  155.       CASE ( nKey == K_CTRL_PGUP )
  156.          b:goTop()
  157.  
  158.       CASE ( nKey == K_CTRL_PGDN )
  159.          b:goBottom()
  160.  
  161.       CASE ( nKey == K_RIGHT )
  162.          b:right()
  163.  
  164.       CASE ( nKey == K_LEFT )
  165.          b:left()
  166.  
  167.       CASE ( nKey == K_HOME )
  168.          b:home()
  169.  
  170.       CASE ( nKey == K_END )
  171.          b:end()
  172.  
  173.       CASE ( nKey == K_CTRL_LEFT )
  174.          b:panLeft()
  175.  
  176.       CASE ( nKey == K_CTRL_RIGHT )
  177.          b:panRight()
  178.  
  179.       CASE ( nKey == K_CTRL_HOME )
  180.          b:panHome()
  181.  
  182.       CASE ( nKey == K_CTRL_END )
  183.          b:panEnd()
  184.  
  185.       CASE ( nKey == K_ESC )
  186.          lMore := .f.
  187.  
  188.       CASE ( nKey == K_RETURN )
  189.          lMore := .f.
  190.  
  191.       ENDCASE
  192.  
  193.    ENDDO
  194.  
  195.    SetCursor(nCursSave)
  196.  
  197. RETURN (.t.)
  198.  
  199. ****
  200. *  SkipWhile()
  201. *
  202. STATIC FUNCTION SkipWhile(n, bWhileCond)
  203. LOCAL i
  204.  
  205.    i := 0
  206.    IF ( LASTREC() <> 0 )
  207.       IF ( n == 0 )
  208.          SKIP 0
  209.  
  210.       ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() )
  211.          WHILE ( i < n )
  212.             SKIP 1
  213.             IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
  214.                SKIP -1
  215.                EXIT
  216.             ENDIF
  217.             i++
  218.          ENDDO
  219.  
  220.       ELSEIF ( n < 0 )
  221.          WHILE ( i > n )
  222.             SKIP -1
  223.             IF ( BOF() )
  224.                EXIT
  225.             ELSEIF .NOT. Eval( (bWhileCond) )
  226.                SKIP
  227.                EXIT
  228.             ENDIF
  229.             i--
  230.          ENDDO
  231.       ENDIF
  232.    ENDIF
  233. RETURN (i)
  234. * EOFcn SkipWhile()
  235.  
  236. ****
  237. *  TBWhileSet()
  238. *
  239. FUNCTION TBWhileSet(cKey)
  240.    * Sets Up nTopNo And nBotNo For TBWhile()
  241.    IF ( cKey == NIL )  // if no cKey, set up for all records
  242.       GOTO BOTTOM
  243.       nBotNo := RECNO()
  244.       GOTO TOP
  245.       nTopNo := RECNO()
  246.       RETURN(.t.)
  247.    ENDIF
  248.  
  249.    SEEK cKey
  250.    IF EOF() .OR. LASTREC() == 0
  251.       nTopNo := nBotNo := 0
  252.       RETURN(.f.)
  253.    ENDIF
  254.  
  255.    nTopNo := RECNO()
  256.    * goto last record for cKey in indexed dbf
  257.    SeekLast(cKey)
  258.    * don't need to check if keyfield = cKey since previous 
  259.    * Seek cKey/IF EOF()/Return(.f.) already showed data present
  260.    nBotNo := RECNO()
  261.    GOTO nTopNo
  262. RETURN(.t.)
  263. * EOFcn TBWhileSet
  264.  
  265. FUNCTION SeekLast(cKey)
  266.    * SeekLast: Finds Last Record For Matching Key
  267.    * Developed By Jon Cole
  268.    * With softseek set on, seek the first record after condition.
  269.    * This is accomplished by incrementing the right most character of the
  270.    * string cKey by one ascii character.  After SEEKing the new string,
  271.    * back up one record to get to the last record which matches cKey.
  272.    SET SOFTSEEK ON
  273.    SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
  274.    SET SOFTSEEK OFF
  275.    SKIP -1
  276. RETURN NIL
  277. * EOFcn SeekLast
  278.  
  279.  
  280. 
  281.