home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / magazine / nan_news / toolkit / tbwhile.prg < prev    next >
Text File  |  1991-08-15  |  15KB  |  465 lines
  1. /*
  2.  * File......: TBWHILE.PRG
  3.  * Author....: Jim Orlowski
  4.  * Date......: $Date:   15 Aug 1991 23:04:20  $
  5.  * Revision..: $Revision:   1.2  $
  6.  * Log file..: $Logfile:   E:/nanfor/src/tbwhile.prv  $
  7.  * 
  8.  * This is an original work by Jim Orlowski and is placed in the
  9.  * public domain.
  10.  *
  11.  * The tricks are: 
  12.  *
  13.  * 1. Setting up functions for goTop() and goBottom() so that you can 
  14.  *    quickly move to the right record when the user presses the 
  15.  *    Ctrl-PgUp ( goTop() ) and Ctrl-PgDn ( goBottom() ) keys.
  16.  *
  17.  * 2. Passing and evaluating the block for the TbSkipWhil().
  18.  *
  19.  * Modification history:
  20.  * ---------------------
  21.  *
  22.  * $Log:   E:/nanfor/src/tbwhile.prv  $
  23.  * 
  24.  *    Rev 1.2   15 Aug 1991 23:04:20   GLENN
  25.  * Forest Belt proofread/edited/cleaned up doc
  26.  * 
  27.  *    Rev 1.1   14 Jun 1991 19:53:08   GLENN
  28.  * Minor edit to file header
  29.  * 
  30.  *    Rev 1.0   01 Apr 1991 01:02:22   GLENN
  31.  * Nanforum Toolkit
  32.  *
  33.  */
  34.  
  35. #command DEFAULT <param> TO <val> [, <paramn> TO <valn> ];
  36. => ;
  37.          <param> := IIF(<param> = NIL, <val>, <param> ) ;
  38.          [; <paramn> := IIF(<paramn> = NIL, <valn>, <paramn> ) ]
  39. #include "inkey.ch"
  40.  
  41.  
  42. #ifdef FT_TEST
  43.  
  44.   /*
  45.    *   THIS DEMO SHOWS TBNAMES.DBF CONSISTING OF LAST, FIRST, ADDR, CITY,
  46.    *   STATE, ZIP WITH ACTIVE INDEX ON LAST + FIRST.  IT SHOWS LAST NAME,
  47.    *   FIRST NAME, CITY ONLY FOR THOSE LAST NAMES THAT BEGIN WITH LETTER
  48.    *   THAT YOU INPUT FOR THE CKEY GET.
  49.    *
  50.    *   TBNAMES.DBF/.NTX ARE AUTOMATICALLY CREATED BY THIS TEST PROGRAM
  51.    */
  52.  
  53.   #INCLUDE "SETCURS.CH"
  54.  
  55.   FUNCTION TBWHILE()
  56.      LOCAL aFields := {}, cKey := "O", cOldColor
  57.      LOCAL nFreeze := 1, lSaveScrn := .t., nRecSel
  58.      LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  59.      LOCAL cColorShad := "N/N"
  60.      MEMVAR GetList
  61.  
  62.      IF ! FILE( "TBNAMES.DBF" )
  63.         MAKE_DBF()
  64.      ENDIF
  65.  
  66.      USE TBNames
  67.  
  68.      IF ! FILE( "TBNAMES.NTX" )
  69.         INDEX ON last + first TO TBNAMES
  70.      ENDIF
  71.  
  72.      SET INDEX TO TBNAMES
  73.  
  74.      * Pass Heading as character and Field as Block including Alias
  75.      * To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
  76.  
  77.      AADD(aFields, {"Last Name" , {||TBNames->Last}  } )
  78.      AADD(aFields, {"First Name", {||TBNames->First} } )
  79.      AADD(aFields, {"City"      , {||TBNames->City}  } )
  80.  
  81.      cOldColor := SetColor("N/BG")
  82.      CLEAR SCREEN
  83.      @ 5,10 SAY "Enter First Letter Of Last Name:" GET cKey PICTURE "!"
  84.      READ
  85.  
  86.      * TBNames->Last = cKey is the Conditional Block passed to this function
  87.      * you can make it as complicated as you want, but you would then
  88.      * have to modify TBWhileSet() to find first and last records
  89.      * matching your key.
  90.      nRecSel := FT_BRWSWHL( aFields, {||TBNames->Last = cKey}, cKey, nFreeze,;
  91.         lSaveScrn, cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6)
  92.      * Note you can use Compound Condition 
  93.      * such as cLast =: "Pierce            " and cFirst =: "Hawkeye  "
  94.      * by changing above block to:
  95.      *    {||TBNames->Last = cLast .AND. TBNames->First = cFirst}
  96.      * and setting cKey := cLast + cFirst
  97.  
  98.      ?
  99.      IF nRecSel == 0
  100.         ? "Sorry, NO Records Were Selected"
  101.      ELSE
  102.         ? "You Selected " + TBNames->Last +" "+ ;
  103.            TBNames->First +" "+ TBNames->City
  104.      ENDIF
  105.      ?
  106.  
  107.      WAIT
  108.      SetColor(cOldColor)
  109.      CLEAR SCREEN
  110.   RETURN nil
  111.  
  112.   STATIC FUNCTION make_dbf
  113.   LOCAL x, aData := {                                                               ;
  114.      { "SHAEFER","KATHRYN","415 WEST CITRUS ROAD #150","LOS ANGELES","CA","90030" },;
  115.      { "OLSON","JAMES","225 NORTH RANCH ROAD","LOS ANGELES","CA","90023"          },;
  116.      { "KAYBEE","JOHN","123 SANDS ROAD","CAMARILLO","CA","93010"                  },;
  117.      { "HERMAN","JIM","123 TOON PAGE ROAD","VENTURA","CA","93001"                 },;
  118.      { "BURNS","FRANK","123 VIRGINA STREET","OXNARD","CA","93030"                 },;
  119.      { "PIERCE","HAWKEYE","123 OLD TOWN ROAD","PORT MUGU","CA","93043"            },;
  120.      { "MORGAN","JESSICA","123 FRONTAGE ROAD","CAMARILLO","CA","93010"            },;
  121.      { "POTTER","ROBERT","123 FIR STREET","OXNARD","CA","93030"                   },;
  122.      { "WORTH","MARY","123-1/2 JOHNSON DRIVE","OXNARD","CA","93033"               },;
  123.      { "JOHNSON","SUSAN","123 QUEENS STREET","OXNARD","CA","93030"                },;
  124.      { "SAMSON","SAM","215 MAIN STREET","OXNARD","CA","93030"                     },;
  125.      { "NEWNAME","JAMES","215 MAIN STREET","LOS ANGELES","CA","90000"             },;
  126.      { "OLEANDAR","JILL","425 FLORAL PARK DRIVE","FLORAL PARK","NY","10093"       },;
  127.      { "SUGARMAN","CANDY","1541 SWEETHEART ROAD","HERSHEY","PA","10132"           } }
  128.  
  129.   DbCreate( "TBNAMES", { { "LAST ", "C", 18, 0, } ,;
  130.                          { "FIRST", "C",  9, 0, } ,;
  131.                          { "ADDR ", "C", 28, 0, } ,;
  132.                          { "CITY ", "C", 21, 0, } ,;
  133.                          { "STATE", "C",  2, 0, } ,;
  134.                          { "ZIP  ", "C",  9, 0, } } )
  135.   USE tbnames
  136.   FOR x := 1 TO Len( aData )
  137.      APPEND BLANK
  138.      Aeval( aData[x], {|e,n| FieldPut( n, e ) } )
  139.   NEXT
  140.   USE
  141.   RETURN NIL
  142.  
  143. #endif
  144.  
  145.  
  146.  
  147. /*  $DOC$
  148.  *  $FUNCNAME$
  149.  *     FT_BRWSWHL()
  150.  *  $CATEGORY$
  151.  *     Menus/Prompts
  152.  *  $ONELINER$
  153.  *     Browse an indexed database limited to a while condition
  154.  *  $SYNTAX$
  155.  *     FT_BRWSWHL( <aFields>, <bWhileCond>, <cKey>,                  ;
  156.  *                 [ <nFreeze> ], [ <lSaveScrn> ], [ <cColorList> ], ;
  157.  *                 [ <cColorShadow> ], [ <nTop> ], [ <nLeft> ],      ;
  158.  *                 [ <nBottom> ], [ <nRight> ] -> nRecno
  159.  *  $ARGUMENTS$
  160.  *     <aFields> is array of field blocks of fields you want to display.
  161.  *        Example to set up last name and first name in array:
  162.  *        aFields := {}
  163.  *        AADD(aFields, {"Last Name" , {||Names->Last}  } )
  164.  *        AADD(aFields, {"First Name", {||Names->First} } )
  165.  *
  166.  *     <bWhileCond> is the limiting WHILE condition as a block.
  167.  *        Example 1: { ||Names->Last == "JONES" }
  168.  *        Example 2: { ||Names->Last == "JONES" .AND. Names->First == "A"  }
  169.  *
  170.  *     <cKey> is the key to find top condition of WHILE.  
  171.  *        cLast  := "JONES     "
  172.  *        cFirst := "A"
  173.  *        Example 1: cKey := cLast
  174.  *        Example 2: cKey := cLast + cFirst
  175.  *
  176.  *     <nFreeze> is number of fields to freeze in TBrowse.  Defaults
  177.  *     to 0 if not passed.
  178.  *
  179.  *     <lSaveScrn> is a logical indicating whether or not you want to
  180.  *     save the screen from the calling program.  Defaults to .T. if
  181.  *     not passed.
  182.  *
  183.  *     <cColorList> is a list of colors for the TBrowse columns.
  184.  *     The 1st color is used as SAY/TBrowse Background and the
  185.  *     3rd and 4th colors are used as part of column:defColor := {3, 4}
  186.  
  187.  *     Thus if you pass a cColorList, you MUST pass at least 4 colors.
  188.  *     Defaults to "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R" if not passed.
  189.  *
  190.  *     <cColorShad> is the color of the TBrowse box shadow.  Defaults
  191.  *     to "N/N" if not passed.
  192.  *
  193.  *     <nTop>, <nLeft>, <nBottom>, <nRight> are the coordinates of
  194.  *     the area to display the TBrowse in.  Defaults to 2, 2,
  195.  *     MAXROW() - 2, MAXCOL() - 2 with shadowed box, i.e. full screen.
  196.  *  $RETURNS$
  197.  *     nRecno is the number of the record selected by the <Enter> key.
  198.  *     0 is returned if there are either no records matching the WHILE
  199.  *     condition or an <Esc> is pressed instead of an <Enter>
  200.  *  $DESCRIPTION$
  201.  *     This is a demonstration of TBrowse with a WHILE condition for an
  202.  *     indexed database.
  203.  *  $EXAMPLES$
  204.  *     * This example will only show those people with last name of "JONES"
  205.  *     * in the TBNames.dbf which contains at least the fields:
  206.  *     * Last, First, City AND is indexed on Last + First.
  207.  *     LOCAL nRecSel    := 0
  208.  *     LOCAL aFields    := {}
  209.  *     LOCAL bWhile     := {||TBNames->Last = "JONES"}
  210.  *     LOCAL cKey       := "JONES"
  211.  *     LOCAL nFreeze    := 1
  212.  *     LOCAL lSaveScrn  := .t.
  213.  *     LOCAL cColorList := "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R"
  214.  *     LOCAL cColorShad := "N/N"
  215.  *
  216.  *     USE TBNames INDEX TBNames NEW // indexed on Last + First
  217.  *
  218.  *     * Pass Heading as character and Field as Block including Alias
  219.  *     * To eliminate the need to use FIELDWBLOCK() function in FT_BRWSWHL()
  220.  *     AADD(aFields, {"Last Name" , {||TBNames->Last}  } )
  221.  *     AADD(aFields, {"First Name", {||TBNames->First} } )
  222.  *     AADD(aFields, {"City"      , {||TBNames->City}  } )
  223.  *
  224.  *     IF FT_BRWSWHL( aFields, bWhile, cKey, nFreeze, lSaveScrn, ;
  225.  *        cColorList, cColorShad, 3, 6, MaxRow() - 2, MaxCol() - 6) == 0
  226.  *        ? "Sorry, NO Records Were Selected"
  227.  *     ELSE
  228.  *        ? "You Selected: " + TBNames->Last +" "+ ;
  229.  *           TBNames->First +" "+ TBNames->City
  230.  *     ENDIF
  231.  *  $END$
  232.  */
  233.  
  234.  
  235. FUNCTION FT_BRWSWHL(aFields, bWhileCond, cKey, nFreeze, lSaveScrn, ;
  236.                     cColorList, cColorShad, nTop, nLeft, nBottom, nRight )
  237.  
  238.    LOCAL b, column, cType, i
  239.    LOCAL cHead, bField, lKeepScrn, cScrnSave
  240.    LOCAL cColorSave, cColorBack, nCursSave
  241.    LOCAL lMore, nKey, nPassRec
  242.    DEFAULT nFreeze TO 0, ;
  243.            lSaveScrn  TO .t., ;
  244.            cColorList TO "N/W, N/BG, B/W, B/BG, B/W, B/BG, R/W, B/R", ;
  245.            cColorShad TO "N/N", ;
  246.            nTop       TO 2, ;
  247.            nLeft      TO 2, ;
  248.            nBottom    TO MaxRow() - 2, ;
  249.            nRight     TO MaxCol() - 2
  250.    lKeepScrn := (PCOUNT() > 6)
  251.  
  252.    SEEK cKey
  253.    IF .NOT. FOUND() .OR. LASTREC() == 0
  254.       RETURN(0)
  255.    ENDIF
  256.  
  257.    /* make new browse object */
  258.    b := TBrowseDB(nTop, nLeft, nBottom, nRight)
  259.  
  260.    /* default heading and column separators */
  261.    b:headSep := "═╤═"
  262.    b:colSep  := " │ "
  263.    b:footSep := "═╧═"
  264.  
  265.    /* add custom 'TbSkipWhil' (to handle passed condition) */
  266.    b:skipBlock := {|x| TbSkipWhil(x, bWhileCond)}
  267.  
  268.    /* Set up substitute goto top and goto bottom */
  269.    /* with While's top and bottom records        */
  270.    b:goTopBlock    := {|| TbWhileTop(cKey)}
  271.    b:goBottomBlock := {|| TbWhileBot(cKey)}
  272.  
  273.    /* colors */
  274.    b:colorSpec := cColorList
  275.  
  276.    /* add a column for each field in the current workarea */
  277.    FOR i = 1 TO LEN(aFields)
  278.       cHead  := aFields[i, 1]
  279.       bField := aFields[i, 2]
  280.  
  281.       /* make the new column */
  282.       column := TBColumnNew( cHead, bField )
  283.  
  284.       /* these are color setups from tbdemo.prg from Nantucket */
  285.       * IF ( cType == "N" )
  286.       *   column:defColor := {5, 6}
  287.       *   column:colorBlock := {|x| if( x < 0, {7, 8}, {5, 6} )}
  288.       *ELSE
  289.       *   column:defColor := {3, 4}
  290.       *ENDIF
  291.  
  292.       /* To simplify I just used 3rd and 4th colors from passed cColorList */
  293.       /* This way 1st is SAY, 2nd is GET, 3rd and 4th are used here, 
  294.       /* 5th is Unselected Get, extras can be used as in tbdemo.prg */
  295.       column:defColor := {3, 4}
  296.  
  297.       b:addColumn(column)
  298.    NEXT
  299.  
  300.    /* freeze columns */
  301.    IF nFreeze <> 0
  302.       b:freeze := nFreeze
  303.    ENDIF
  304.  
  305.    /* save old screen and colors */
  306.    IF lSaveScrn
  307.       cScrnSave = SAVESCREEN(0, 0, 24, 79)
  308.    ENDIF
  309.    cColorSave := SetColor()
  310.  
  311.    /* Background Color Is Based On First Color In Passed cColorList
  312.    cColorBack := IF(',' $ cColorList, ;
  313.       SUBSTR(cColorList, 1, AT(',', cColorList) - 1), cColorList )
  314.  
  315.    IF .NOT. lKeepScrn
  316.       SetColor(cColorBack)
  317.       CLEAR SCREEN
  318.    ENDIF
  319.  
  320.    /* make a window shadow */
  321.    SetColor(cColorShad)
  322.    @ nTop+1, nLeft+1 CLEAR TO nBottom+1, nRight+1
  323.    SetColor(cColorBack)
  324.    @ nTop, nLeft CLEAR TO nBottom, nRight
  325.    SetColor(cColorSave)
  326.  
  327.    nCursSave := SetCursor(0)
  328.  
  329.    lMore := .t.
  330.    WHILE (lMore)
  331.       /* stabilize the display */
  332.       WHILE ( .NOT. b:stabilize() )
  333.          nKey := INKEY()
  334.          IF ( nKey <> 0 )
  335.             EXIT        /* (abort IF a key is waiting) */
  336.          ENDIF
  337.       ENDDO
  338.  
  339.       IF ( b:stable )
  340.          /* display is stable */
  341.          IF ( b:hitTop .OR. b:hitBottom )
  342.             Tone(125, 0)
  343.          ENDIF
  344.  
  345.          /* everything's done; just wait for a key */
  346.          nKey := INKEY(0)
  347.       ENDIF
  348.  
  349.       /* process key */
  350.       DO CASE
  351.       CASE ( nKey == K_DOWN )
  352.          b:down()
  353.  
  354.       CASE ( nKey == K_UP )
  355.          b:up()
  356.  
  357.       CASE ( nKey == K_PGDN )
  358.          b:pageDown()
  359.  
  360.       CASE ( nKey == K_PGUP )
  361.          b:pageUp()
  362.  
  363.       CASE ( nKey == K_CTRL_PGUP )
  364.          b:goTop()
  365.  
  366.       CASE ( nKey == K_CTRL_PGDN )
  367.          b:goBottom()
  368.  
  369.       CASE ( nKey == K_RIGHT )
  370.          b:right()
  371.  
  372.       CASE ( nKey == K_LEFT )
  373.          b:left()
  374.  
  375.       CASE ( nKey == K_HOME )
  376.          b:home()
  377.  
  378.       CASE ( nKey == K_END )
  379.          b:end()
  380.  
  381.       CASE ( nKey == K_CTRL_LEFT )
  382.          b:panLeft()
  383.  
  384.       CASE ( nKey == K_CTRL_RIGHT )
  385.          b:panRight()
  386.  
  387.       CASE ( nKey == K_CTRL_HOME )
  388.          b:panHome()
  389.  
  390.       CASE ( nKey == K_CTRL_END )
  391.          b:panEnd()
  392.  
  393.       CASE ( nKey == K_ESC )
  394.          nPassRec := 0
  395.          lMore := .f.
  396.  
  397.       CASE ( nKey == K_RETURN )
  398.          nPassRec := RECNO()
  399.          lMore := .f.
  400.       ENDCASE
  401.    ENDDO  // for WHILE (lmore)
  402.  
  403.    /* restore old screen */
  404.    IF lSaveScrn
  405.       RESTSCREEN(0, 0, 24, 79, cScrnSave)
  406.    ENDIF
  407.    SetCursor(nCursSave)
  408.    SetColor(cColorSave)
  409.  
  410. RETURN (nPassRec)
  411.  
  412.  
  413.  
  414. STATIC FUNCTION TbSkipWhil(n, bWhileCond)
  415.    LOCAL i
  416.  
  417.    i := 0
  418.    IF ( LASTREC() <> 0 )
  419.       IF ( n == 0 )
  420.          SKIP 0
  421.  
  422.       ELSEIF ( n > 0 .AND. RECNO() <> LASTREC() )
  423.          WHILE ( i < n )
  424.             SKIP 1
  425.             IF ( EOF() .OR. .NOT. Eval(bWhileCond) )
  426.                SKIP -1
  427.                EXIT
  428.             ENDIF
  429.             i++
  430.          ENDDO
  431.  
  432.       ELSEIF ( n < 0 )
  433.          WHILE ( i > n )
  434.             SKIP -1
  435.             IF ( BOF() )
  436.                EXIT
  437.             ELSEIF .NOT. Eval( (bWhileCond) )
  438.                SKIP
  439.                EXIT
  440.             ENDIF
  441.             i--
  442.          ENDDO
  443.       ENDIF
  444.    ENDIF
  445. RETURN (i)
  446. * EOFcn TbSkipWhil()
  447.  
  448. STATIC FUNCTION TbWhileTop(cKey)
  449.    SEEK cKey
  450. RETURN NIL
  451.  
  452. STATIC FUNCTION TbWhileBot(cKey)
  453.    * SeekLast: Finds Last Record For Matching Key
  454.    * Developed By Jon Cole
  455.    * With softseek set on, seek the first record after condition.
  456.    * This is accomplished by incrementing the right most character of the
  457.    * string cKey by one ascii character.  After SEEKing the new string,
  458.    * back up one record to get to the last record which matches cKey.
  459.    #include "set.ch"
  460.    LOCAL cSoftSave := SET(_SET_SOFTSEEK, .t.)
  461.    SEEK LEFT(cKey, LEN(cKey) -1) + CHR( ASC( RIGHT(cKey,1) ) +1)
  462.    SET(_SET_SOFTSEEK, cSoftSave)
  463.    SKIP -1
  464. RETURN NIL
  465.