home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / nfsrc21.zip / POPADDER.PRG < prev    next >
Text File  |  1991-08-17  |  45KB  |  1,292 lines
  1. /*
  2.  * File......: Popadder.prg
  3.  * Author....: Keith A. Wire
  4.  * CIS ID....: 73760,2427
  5.  * Date......: $Date:   17 Aug 1991 15:44:30  $
  6.  * Revision..: $Revision:   1.2  $
  7.  * Log file..: $Logfile:   E:/nanfor/src/popadder.prv  $
  8.  * 
  9.  * This is an original work by Keith A. Wire and is placed in the
  10.  * public domain.
  11.  *
  12.  * Modification history:
  13.  * ---------------------
  14.  *
  15.  * $Log:   E:/nanfor/src/popadder.prv  $
  16.  * 
  17.  *    Rev 1.2   17 Aug 1991 15:44:30   GLENN
  18.  * Don Caton fixed some spelling errors in the doc
  19.  * 
  20.  *    Rev 1.1   15 Aug 1991 23:04:12   GLENN
  21.  * Forest Belt proofread/edited/cleaned up doc
  22.  * 
  23.  *    Rev 1.0   14 Jun 1991 17:37:54   GLENN
  24.  * Initial revision.
  25.  *
  26.  */
  27.  
  28.  
  29. /*
  30.  * File......: Popadder.prg
  31.  * Author....: Keith A. Wire
  32.  * CIS ID....: 73760,2427
  33.  * Date......: $Date:   17 Aug 1991 15:44:30  $
  34.  * Revision..: $Revision:   1.2  $
  35.  * Log file..: $Logfile:   E:/nanfor/src/popadder.prv  $
  36.  * 
  37.  * This is an original work by Keith A. Wire and is placed in the
  38.  * public domain.
  39.  *
  40.  * Modification history:
  41.  * ---------------------
  42.  *
  43.  * $Log$
  44.  * 
  45.  *    Rev 1.0   14 Jun 1991 17:37:54   GLENN
  46.  * Initial revision.
  47.  *
  48.  */
  49.  
  50.  
  51. /*  $DOC$
  52.  *  $FUNCNAME$
  53.  *      FT_Adder()
  54.  *  $CATEGORY$
  55.  *      Menus/Prompts
  56.  *  $ONELINER$
  57.  *      Pop up a simple calculator
  58.  *  $SYNTAX$
  59.  *      FT_Adder()
  60.  *  $ARGUMENTS$
  61.  *      None
  62.  *  $RETURNS$
  63.  *      NIL .... but optionally places Total of calculation in active 
  64.  *               Get variable using oGet:VARPUT()
  65.  *  $DESCRIPTION$
  66.  *      PopAdder() gives you an adding machine inside your Clipper 5.01
  67.  *      application. It has the basic functions add, subtract, multiply,
  68.  *      and divide. You may move it from one side of the screen to the
  69.  *      other. It even displays a scrollable tape, if you want it.
  70.  *
  71.  *
  72.  *      The Help screen below gives a brief description of the operation
  73.  *      of the adder.              
  74.  *          
  75.  *
  76.  *                  ┌─────── INSTRUCTIONS ───────┐
  77.  *                  │                            │
  78.  *                  │ All number keys as usual   │
  79.  *                  │ <+> <-> keys as usual      │
  80.  *                  │ <SPACE>─┬─shift <+> to <*> │
  81.  *                  │         └─shift <-> to </> │
  82.  *                  │  <D>    change decimal pt. │
  83.  *                  │  <M>    move ADDER         │
  84.  *                  │  <T>    display tape       │
  85.  *                  │  <S>    scroll tape disp.  │
  86.  *                  │ <DEL>───┬─1st Clear entry  │
  87.  *                  │         └─2nd Clear ADDER  │
  88.  *                  │ <ESC>   to Quit            │
  89.  *                  │ <F10>   to Return Total    │
  90.  *                  │           to program       │
  91.  *                  │                            │
  92.  *                  └──── Any Key to Continue ───┘
  93.  *
  94.  *
  95.  *
  96.  *      A couple of notes about the adder:
  97.  *
  98.  *
  99.  *      1.) It was designed to be used on an Enhanced keyboard with
  100.  *          separate <DELETE> key. <DELETE> is used to clear the adder.
  101.  *          However, it will still work on a Standard keyboard.
  102.  *
  103.  *      2.) It uses the <SPACE> bar to shift from Add/Subtract
  104.  *          mode to Multiply/Divide. That means the <+> and <-> keys
  105.  *          become the <*> and </> keys.   
  106.  *
  107.  *      3.) You do not have to display the tape. You may turn it on
  108.  *          at any time by pressing <T>. You may SCROLL back through
  109.  *          the tape once there are more than 16 entries in the 
  110.  *          adder, by pressing <S>.
  111.  *
  112.  *      4.) To Quit the Adder just press <ESC>. To return your Total
  113.  *          to the application press <F10>. The adder will place the
  114.  *          Total in the active GET variable using oGet:VarPut(). The
  115.  *          adder will only return a Total to a numerical GET!
  116.  *
  117.  *      5.) There are many support functions that you might find
  118.  *          interesting. They are part of my personal library, but 
  119.  *          are necessary to the operation of the adder.
  120.  *          You might want to pull these out to reduce the overall
  121.  *          size of the adder. Many are worth at least a little
  122.  *          time studying.
  123.  *
  124.  *      6.) To make FT_Adder a Hot key from inside your application
  125.  *          at the beginning of your application add the line:
  126.  *
  127.  *                 SET KEY K_ALT_A  TO FT_Adder
  128.  *
  129.  *          This will make <ALT-A> a key "Hot" and permit you to 
  130.  *          Pop - Up the adder from anywhere in the application.
  131.  *
  132.  *      7.) If you use FT_SINKEY(), you can even have active hotkeys
  133.  *          in an INKEY().
  134.  *
  135.  *
  136.  *
  137.  *
  138.  *  $EXAMPLES$
  139.  *  
  140.  *  $SEEALSO$
  141.  *
  142.  *  $INCLUDE$
  143.  *     INKEY.CH, SET.CH, SETCURS.CH, ACHOICE.CH
  144.  *  $END$
  145.  */
  146.  
  147. #include 'Inkey.ch'
  148. #include 'Set.ch'
  149. #include 'SetCurs.ch'
  150. #include 'achoice.ch'
  151.  
  152. #define K_PLUS  43
  153. #define K_MINUS 45
  154. #define K_SPACE 32
  155. #define nTotTran LEN(aTrans)
  156. #define MUST_READ .T.
  157. #define POP_ON    .T.
  158. #define POP_OFF   .F.
  159. #define B_DOUBLE '╔═╗║╝═╚║ '
  160. #define B_SINGLE '┌─┐│┘─└│ '
  161.  
  162. // Set up manifest constants to access the window colors in the array aWinColor
  163. #define W_BORDER 1
  164. #define W_ACCENT 2
  165. #define W_PROMPT 3
  166. #define W_SCREEN 4
  167. #define W_TITLE  5
  168. #define W_VARIAB 6
  169. #define W_CURR   NIL
  170.  
  171. // Set up manifest constants to access the Standard screen colors in the array
  172. // aStdColor
  173. #define STD_ACCENT   1
  174. #define STD_ERROR    2
  175. #define STD_PROMPT   3
  176. #define STD_SCREEN   4
  177. #define STD_TITLE    5
  178. #define STD_VARIABLE 6
  179. #define STD_BORDER   7
  180.  
  181.  
  182. /* This ASHRINK is by Rick Spence */
  183. #define ASHRINK(ar) ASIZE(ar,LEN(ar)-1)
  184.  
  185. #command DISPMESSAGE <mess>,<t>,<l>,<b>,<r> => ;
  186.          _ftPushKeys(); KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_CTRL_W);;
  187.          MEMOEDIT(<mess>,<t>,<l>,<b>,<r>); _ftPopKeys()
  188.  
  189. /* This INKEY UDC was posted by Don Caton on NanForum... Thanks Don <g> */
  190. #command INKEY [ <secs> ] TO <var>                                       ;
  191.          =>                                                            ;
  192.          WHILE (.T.)                                                  ;;
  193.             <var> := Inkey([ <secs> ])                                  ;;
  194.             IF Setkey(<var>) # NIL                                    ;;
  195.                Eval( Setkey(<var>), ProcName(), ProcLine(), #<var> )  ;;
  196.             ELSE                                                      ;;
  197.                EXIT                                                   ;;
  198.             END                                                       ;;
  199.          END
  200.  
  201. MEMVAR getlist
  202.  
  203. STATIC nTotal,nNumTotal,nSavTotal,cDefTotPict,cTotPict,lShowRight
  204. STATIC nAddSpace,nTapeSpace,nTopTape,lClAdder,lDecSet,nDecDigit,nMaxDeci
  205. STATIC lMultDiv,nAddMode,lSubRtn,cTapeScr,lTotalOk,lAddError
  206. STATIC aTrans,lTape, nTopOS, nLeftOS, lNewNum, nSavSubTotal, lDivideErr
  207.  
  208. STATIC aHelpStack := {}, aKeys := {}
  209. STATIC lStatMustRing := .T.             // Change this to .F. if you don't
  210.                                         // want the bell on inputs
  211.  
  212. STATIC aWindow   := {}, nWinColor := 0  
  213. STATIC aWinColor, aStdColor
  214.  
  215. #ifdef FT_TEST
  216.  
  217.   FUNCTION TEST
  218.  
  219.     LOCAL nSickHrs := 0, ;
  220.           nPersHrs := 0, ;
  221.           nVacaHrs := 0
  222.  
  223.     aWinColor := { {'GR+/BG','GR+/G', 'B+/RB', 'G+/R'} , ;
  224.                    {'R+/N',   'W+/RB','W+/BG','GR+/B'} , ;
  225.                    {'GR+/N', 'GR+/N','GR+/N', 'GR+/N'} , ;
  226.                    {  'B/BG','BG+/G', 'W+/RB','BG+/R'} , ;
  227.                    { 'W+/BG', 'W+/G','GR+/RB', 'W+/R'} , ;
  228.                    {'GR+/B', 'GR+/R', 'R+/B',  'W+/BG'},; 
  229.                    {  'N/N',   'N/N',  'N/N',   'N/N'}   }
  230.  
  231.     aStdColor := { 'BG+*/RB' , ;                          
  232.                     'GR+/R'  , ;                          
  233.                     'GR+/N'  , ;                          
  234.                       'W/B'  , ;                          
  235.                     'GR+/N'  , ;                          
  236.                     'GR+/GR' , ;                          
  237.                    { 'W+/B',  'W/B','G+/B','R+/B',;       
  238.                     'GR+/B','BG+/B','B+/B','G+/B'},;
  239.                       'N/N'    }
  240.  
  241.     SET SCOREBOARD OFF
  242.     _ftSetScrColor(STD_SCREEN,STD_VARIABLE)
  243.     CLEAR SCREEN
  244.  
  245.     SET KEY K_ALT_A  TO FT_Adder        // Make <ALT-A> call FT_Adder
  246.  
  247.     * SIMPLE Sample of program data entry!
  248.  
  249.  
  250.     @ 12,5 SAY 'Please enter the total Sick, Personal, and Vacation hours.'
  251.     @ 15,22 SAY 'Sick hrs.'
  252.     @ 15,40 SAY 'Pers. hrs.'
  253.     @ 15,60 SAY 'Vaca. hrs.'
  254.     @ 23,20 SAY 'Press <ALT-A> to Pop - Up the Adder.'
  255.     @ 24,20 SAY 'Press <ESC> to Quit the adder Demo.'
  256.     DO WHILE .T.                               // Get the sick, personal, & vacation
  257.       @ 16,24 GET nSickHrs PICTURE '9999.999'  // Normally I have a VALID()
  258.       @ 16,43 GET nPersHrs PICTURE '9999.999'  // to make sure the value is
  259.       @ 16,63 GET nVacaHrs PICTURE '9999.999'  // within the allowable range.
  260.       SET CURSOR ON                            // But, like I said it is a
  261.       CLEAR TYPEAHEAD                          // SIMPLE example <g>.
  262.       READ
  263.       SET CURSOR OFF
  264.       IF LASTKEY() == K_ESC                    // <ESC> - ABORT
  265.         CLEAR TYPEAHEAD
  266.         EXIT
  267.       ENDIF
  268.     ENDDO
  269.     SET CURSOR ON
  270.  
  271.     SET KEY K_ALT_A                     // Reset <ALT-A>
  272.  
  273.   RETURN NIL
  274. #endif
  275.  
  276.  
  277. FUNCTION FT_Adder                       // "KAW" ADDER
  278.   
  279.   LOCAL cOldColor,nOldCurs,nOldDecim,nOldRow,nOldCol,nKey
  280.   LOCAL bOldF10,nOldLastKey, cMoveTotSubTot, cTotal
  281.   LOCAL oGet := GetActive()
  282.  
  283.   aWinColor := { {'GR+/BG','GR+/G', 'B+/RB', 'G+/R'} , ; 
  284.                  {'R+/N',   'W+/RB','W+/BG','GR+/B'} , ; 
  285.                  {'GR+/N', 'GR+/N','GR+/N', 'GR+/N'} , ; 
  286.                  {  'B/BG','BG+/G', 'W+/RB','BG+/R'} , ; 
  287.                  { 'W+/BG', 'W+/G','GR+/RB', 'W+/R'} , ; 
  288.                  {'GR+/B', 'GR+/R', 'R+/B',  'W+/BG'},; 
  289.                  {  'N/N',   'N/N',  'N/N',   'N/N'}   }
  290.  
  291.   aStdColor := { 'BG+*/RB' , ;                          
  292.                   'GR+/R'  , ;                          
  293.                   'GR+/N'  , ;                          
  294.                     'W/B'  , ;                          
  295.                   'GR+/N'  , ;                          
  296.                   'GR+/GR' , ;                          
  297.                  { 'W+/B',  'W/B','G+/B','R+/B',;       
  298.                   'GR+/B','BG+/B','B+/B','G+/B'},;
  299.                     'N/N'    }
  300.  
  301.   nOldLastKey := LASTKEY()
  302.   bOldF10 := SETKEY(K_F10,NIL)
  303.   aTrans := {}
  304.   SET KEY K_ALT_A  TO                   // Turn off Adder
  305.   lDivideErr := .F.
  306.   cOldColor  :=  SETCOLOR()
  307.   nOldCurs   := SETCURSOR(SC_NONE)
  308.   nOldDecim  := SET(_SET_DECIMALS,9)
  309.   nOldRow    := ROW()
  310.   nOldCol    := COL()
  311.   cDefTotPict:= '999999999999999999'
  312.   cTotPict   := ''
  313.   nTotal     := nNumTotal := nSavTotal := nKey := nDecDigit := nMaxDeci := 0
  314.   nSavSubTotal := 0
  315.   lNewNum    := .F.
  316.   lShowRight := .T.
  317.   nTopOS     := INT((MAXROW()-24)/2)    // Using the TopOffSet & LeftOffSet
  318.   nLeftOS    := INT((MAXCOL()-79)/2)    // the Adder will always be centered
  319.   nAddSpace  := IF(lShowRight,40,0)+nLeftOS
  320.   nTapeSpace := IF(lShowRight,0,40)+nLeftOS
  321.   cTapeScr   := ''
  322.   nTopTape   := 1
  323.   nAddMode   := 1                       // Start in ADD mode
  324.   lMultDiv   := .F.                     // Start in ADD mode
  325.   lClAdder   := .F.                     // Clear adder flag
  326.   lDecSet    := .F.                     // Decimal ? - keyboard routine
  327.   lSubRtn    := lTotalOk := lTape := lAddError := .F.
  328.   _ftAddScreen()
  329.   _ftChangeDec(2)
  330.   CLEAR TYPEAHEAD
  331.   DO WHILE .T.                          // Input key & test loop
  332.     INKEY 0 TO nKey
  333.     DO CASE
  334.       CASE UPPER(CHR(nKey)) $'1234567890.'
  335.         _ftEraseTotSubTot()
  336.         _ftProcessNumb(nKey)
  337.       CASE nKey == K_PLUS               // <+> sign
  338.         _ftEraseTotSubTot()
  339.         _ftAddNum(nKey)
  340.       CASE nKey == K_MINUS              // <-> sign
  341.         _ftEraseTotSubTot()
  342.         _ftAddNum(nKey)
  343.       CASE nKey == K_RETURN             // <RTN> Total or Subtotal
  344.         _ftEraseTotSubTot()
  345.         _ftAddTotal()
  346.       CASE nKey == K_ESC                // <ESC> Quit
  347.         _ftEraseTotSubTot()
  348.         SET(_SET_DECIMALS,nOldDecim)
  349.         SETCURSOR(nOldCurs)
  350.         IF lTape
  351.           RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
  352.         ENDIF
  353.         _ftPopWin()
  354.         SETCOLOR(cOldColor)
  355.         SETPOS(nOldRow,nOldCol)
  356.         _ftSetLastKey(nOldLastKey)
  357.         SETKEY(K_F10,bOldF10)
  358.         SET KEY K_ALT_A  TO FT_Adder    // Turn on Adder
  359.         RETU NIL
  360.       CASE nKey == 68 .OR. nKey == 100  // <D> Change number of decimal places
  361.         _ftChangeDec()
  362.       CASE nKey == 84 .OR. nKey == 116  // <T> Display Tape
  363.         _ftDisplayTape(nKey)
  364.       CASE nKey == 77 .OR. nKey == 109  // <M> Move Adder
  365.         IF lTape
  366.           RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
  367.         ENDIF
  368.         IF LEFT(SAVESCREEN(8+nTopOS,26+nAddSpace,8+nTopOS,27+nAddSpace),1) ;
  369.               != ' '
  370.           IF LEFT(SAVESCREEN(8+nTopOS,19+nAddSpace,8+nTopOS,20+nAddSpace),1) ;
  371.               == 'S'
  372.             cMoveTotSubTot := 'S'
  373.           ELSE
  374.             cMoveTotSubTot := 'T'
  375.           ENDIF
  376.         ELSE
  377.           cMoveTotSubTot := ' '
  378.         ENDIF
  379.         cTotal := _ftCharOdd(SAVESCREEN(5+nTopOS,8+nAddSpace,5+nTopOS,25+nAddSpace))
  380.         _ftPopWin()                      // Remove Adder
  381.         lShowRight := !lShowRight
  382.         nAddSpace  := IF(lShowRight,40,0)+nLeftOS
  383.         nTapeSpace := IF(lShowRight,0,40)+nLeftOS
  384.         _ftAddScreen()
  385.         _ftDispTotal()
  386.         IF lTape
  387.           lTape := .F.
  388.           _ftDisplayTape(nKey)
  389.         ENDIF
  390.         @ 5+nTopOS, 8+nAddSpace SAY cTotal
  391.         IF !EMPTY(cMoveTotSubTot)
  392.           _ftSetWinColor(W_CURR,W_SCREEN)
  393.           @ 8+nTopOS,18+nAddSpace SAY IF(cMoveTotSubTot=='T', '   <TOTAL>', ;
  394.                                                              '<SUBTOTAL>')
  395.           _ftSetWinColor(W_CURR,W_PROMPT)
  396.         ENDIF
  397.       CASE (nKey == 83 .OR. nKey == 115) .AND. lTape  // <S> Scroll display of tape
  398.         IF nTotTran>16                  // We need to scroll
  399.           SETCOLOR('GR+/W')
  400.           @ 21+nTopOS,8+nTapeSpace SAY ' '+CHR(24)+CHR(25)+'-SCROLL  <ESC>-QUIT '
  401.           SETCOLOR('N/W,W+/N')
  402.           ACHOICE(5+nTopOS,7+nTapeSpace,20+nTopOS,31+nTapeSpace,aTrans,.T., ;
  403.                   '__ftAdderTapeUDF',nTotTran,20)
  404.           SETCOLOR('R+/W')
  405.           @ 21+nTopOS,8+nTapeSpace TO 21+nTopOS,30+nTapeSpace
  406.           _ftSetWinColor(W_CURR,W_PROMPT)
  407.           CLEAR TYPEAHEAD
  408.         ELSE
  409.           _ftError('but there are '+IF(nTotTran>0,'only '+LTRIM(;
  410.                   STR(nTotTran,3,0)),'no')+' transactions entered so far. '+;
  411.                   'No need to scroll!')
  412.         ENDIF
  413.       CASE nKey == K_SPACE              // Space bar - Shift to Multiply/Divide
  414.         _ftEraseTotSubTot()
  415.         _ftShiftAdd()
  416.       CASE nKey == 7                    // Delete - Clear adder
  417.         _ftEraseTotSubTot()
  418.         _ftClearAdder()
  419.       CASE nKey == K_F1                 // <F1> Help
  420.         _ftAddHelp()
  421.       CASE nKey == K_F10                // <F10> Quit - Return total
  422.         IF lTotalOk                     // Did they finish the calculation
  423.           IF oGet != NIL .AND. oGet:TYPE == 'N'
  424.             SET(_SET_DECIMALS,nOldDecim)
  425.             SETCURSOR(nOldCurs)
  426.             IF lTape
  427.               RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
  428.             ENDIF
  429.             _ftPopWin()
  430.             SETCOLOR(cOldColor)
  431.             SETPOS(nOldRow,nOldCol)
  432.             _ftSetLastKey(nOldLastKey)
  433.             SETKEY(K_F10,bOldF10)
  434.             SET KEY K_ALT_A  TO FT_Adder    // Turn on Adder
  435.             oGet:VARPUT(nSavTotal)
  436.             RETU NIL
  437.           ELSE
  438.             _ftError('but I can not return the total from the '+;
  439.                     'adder to this variable. You must quit the adder using'+;
  440.                     ' the <ESC> key and then enter the total manually.')
  441.           ENDIF
  442.         ELSE
  443.           _ftError('the calculation is not finished yet! You must have'+;
  444.                   ' a TOTAL before you can return it to the program.')
  445.         ENDIF
  446.     ENDCASE
  447.   ENDDO  (WHILE .T.  Data entry from keyboard)
  448. RETURN NIL
  449. **************
  450.  
  451. STATIC FUNCTION _ftAddScreen             // Part of "KAW" ADDER
  452.   LOCAL nCol
  453.   _ftPushWin(2+nTopOS,2+nAddSpace,22+nTopOS,30+nAddSpace,'   Adder   ', ;
  454.           '<F-1> for Help',,B_DOUBLE)
  455.   nCol := 5+nAddSpace
  456.   @  9+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
  457.   @ 10+nTopOS, nCol SAY '│   │ │   │ │   │ │   │'
  458.   @ 11+nTopOS, nCol SAY '└───┘ └───┘ └───┘ └───┘'
  459.   @ 12+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
  460.   @ 13+nTopOS, nCol SAY '│   │ │   │ │   │ │   │'
  461.   @ 14+nTopOS, nCol SAY '└───┘ └───┘ └───┘ └───┘'
  462.   @ 15+nTopOS, nCol SAY '┌───┐ ┌───┐ ┌───┐ ┌───┐'
  463.   @ 16+nTopOS, nCol SAY '│   │ │   │ │   │ │   │'
  464.   @ 17+nTopOS, nCol SAY '└───┘ └───┘ └───┘ │   │'
  465.   @ 18+nTopOS, nCol SAY '┌─────────┐ ┌───┐ │   │'
  466.   @ 19+nTopOS, nCol SAY '│         │ │   │ │   │'
  467.   @ 20+nTopOS, nCol SAY '└─────────┘ └───┘ │   │'
  468.   @ 21+nTopOS, nCol SAY '                  └───┘'
  469.   _ftSetWinColor(W_CURR,W_TITLE)
  470.   nCol := 7+nAddSpace
  471.   @ 10+nTopOS, nCol SAY '7'
  472.   @ 13+nTopOS, nCol SAY '4'
  473.   @ 16+nTopOS, nCol SAY '1'
  474.   nCol := 13+nAddSpace
  475.   @ 10+nTopOS,nCol SAY '8'
  476.   @ 13+nTopOS,nCol SAY '5'
  477.   @ 16+nTopOS,nCol SAY '2'
  478.   nCol := 19+nAddSpace
  479.   @ 10+nTopOS,nCol SAY '9'
  480.   @ 13+nTopOS,nCol SAY '6'
  481.   @ 16+nTopOS,nCol SAY '3'
  482.   @ 19+nTopOS,nCol SAY '.'
  483.   @ 19+nTopOS,10+nAddSpace SAY '0'
  484.   nCol := 25+nAddSpace
  485.   IF lMultDiv
  486.     @ 10+nTopOS,nCol SAY '÷'
  487.     @ 13+nTopOS,nCol SAY 'X'
  488.     @ 18+nTopOS,nCol SAY '='
  489.   ELSE
  490.     @ 10+nTopOS,nCol SAY '-'
  491.     @ 13+nTopOS,nCol SAY '+'
  492.     @ 17+nTopOS,nCol SAY ''
  493.     @ 19+nTopOS,nCol SAY '*'
  494.   ENDIF
  495.   _ftSetWinColor(W_CURR,W_PROMPT)
  496.   @ 3+nTopOS,6+nAddSpace,7+nTopOS,27+nAddSpace BOX B_DOUBLE
  497. RETURN NIL
  498. **************
  499.  
  500. STATIC FUNCTION _ftChangeDec(nNumDec)   // Change the decimal position in the
  501.   LOCAL y                               // display
  502.   IF nNumDec == NIL
  503.     nNumDec := 0
  504.     nNumDec := _ftQuestion('How many decimals do you want to display?',nNumDec,;
  505.                         '9',{|oGet| _ftValDeci(oGet)},MUST_READ)
  506.   ENDIF
  507.   cTotPict := _ftPosRepl(cDefTotPict,'.',18-ABS(nNumDec))
  508.   FOR y=14-ABS(nNumDec) TO 2 STEP -4
  509.     cTotPict := _ftPosRepl(cTotPict,',',y)
  510.   NEXT
  511.   nMaxDeci := nNumDec
  512.   _ftDispTotal()
  513. RETURN NIL
  514. **************
  515.  
  516. STATIC FUNCTION _ftDispTotal            // Display total number to Adder Window
  517.   LOCAL cTotStr
  518.   IF nTotal>VAL(_ftCharRem(',',cTotPict))  // Part of "KAW" ADDER
  519.     cTotStr := _ftStuffComma(LTRIM(STR(nTotal)))
  520.     _ftError('but that number is to big to display! '+;
  521.     'I believe the answer was '+cTotStr+'.')
  522.     @ 5+nTopOS, 8+nAddSpace SAY ' ****  ERROR  ****'
  523.     lAddError := .T.
  524.     _ftUpdateTrans(.T.)
  525.     _ftClearAdder()
  526.     nTotal    := 0
  527.     nNumTotal := 0
  528.     lAddError := .F.
  529.   ELSE
  530.     @ 5+nTopOS, 8+nAddSpace SAY nTotal PICTURE cTotPict
  531.   ENDIF
  532. RETURN NIL
  533. **************
  534.  
  535. STATIC FUNCTION _ftDispSubTot           // Display subtotal number
  536.   LOCAL cStotStr
  537.   IF nNumTotal>VAL(_ftCharRem(',',cTotPict))
  538.     cStotStr := _ftStuffComma(LTRIM(STR(nNumTotal)))
  539.     _ftError('but that number is to big to display! '+;
  540.     'I believe the answer was '+cStotStr+'.')
  541.     @ 5+nTopOS, 8+nAddSpace SAY ' ****  ERROR  ****'
  542.     lAddError := .T.
  543.     _ftUpdateTrans(.T.,nNumTotal)
  544.     _ftClearAdder()
  545.     nTotal    := 0
  546.     nNumTotal := 0
  547.     lAddError := .F.
  548.   ELSE
  549.     @ 5+nTopOS, 8+nAddSpace SAY nNumTotal PICTURE cTotPict
  550.   ENDIF
  551. RETURN NIL
  552. **************
  553.  
  554. STATIC FUNCTION _ftProcessNumb(nKey)    // Act on NUMBER key pressed
  555.   LOCAL nNum
  556.   lTotalOk  := .F.
  557.   lClAdder  := .F.                      // Reset the Clear flag
  558.   lAddError := .F.                      // Reset adder error flag
  559.   IF nKey=46                            // Period (.) decimal point
  560.     IF lDecSet                          // Has decimal already been set
  561.       _ftRingBell(.T.)
  562.     ELSE
  563.       lDecSet := .T.
  564.     ENDIF
  565.   ELSE                                  // It must be a number input
  566.     lNewNum := .T.
  567.     nNum := nKey-48
  568.     IF lDecSet                          // Decimal set
  569.       IF nDecDigit<nMaxDeci             // Check how many decimals they are allowed
  570.         nDecDigit := ++nDecDigit
  571.         nNumTotal := nNumTotal+nNum/(10**nDecDigit)
  572.       ENDIF
  573.     ELSE
  574.       nNumTotal := nNumTotal*10+nNum
  575.     ENDIF
  576.   ENDIF
  577.   _ftDispSubTot()
  578. RETURN NIL
  579. **************
  580.  
  581. STATIC FUNCTION _ftShiftAdd             // They pressed the space bar
  582.   LOCAL nCol
  583.   nCol := 25+nAddSpace
  584.   _ftSetWinColor(W_CURR,W_TITLE)
  585.   IF lMultDiv                           // toggle add/subt for mult/divide
  586.     lMultDiv := .F.
  587.     @ 10+nTopOS,nCol SAY '-'
  588.     @ 13+nTopOS,nCol SAY '+'
  589.     @ 18+nTopOS,nCol SAY ' '
  590.     @ 17+nTopOS,nCol SAY ''
  591.     @ 19+nTopOS,nCol SAY '*'
  592.   ELSE
  593.     lMultDiv := .T.
  594.     @ 10+nTopOS,nCol SAY '÷'
  595.     @ 13+nTopOS,nCol SAY 'X'
  596.     @ 18+nTopOS,nCol SAY '='
  597.     @ 17+nTopOS,nCol SAY ' '
  598.     @ 19+nTopOS,nCol SAY ' '
  599.   ENDIF
  600.   _ftSetWinColor(W_CURR,W_PROMPT)
  601. RETURN NIL
  602. **************
  603.  
  604. STATIC FUNCTION _ftAddTotal             // Enter key - SUBTOTAL\TOTAL
  605.   lDecSet   := .F.
  606.   nDecDigit := 0
  607.   lClAdder  := .F.                      // Reset the Clear flag
  608.   IF lSubRtn                            // If this was the second time they
  609.     IF !lMultDiv
  610.       _ftSetWinColor(W_CURR,W_SCREEN)
  611.       @ 8+nTopOS,18+nAddSpace SAY '   <TOTAL>'
  612.       _ftSetWinColor(W_CURR,W_PROMPT)
  613.       _ftUpdateTrans(.T.)
  614.       _ftDispTotal()
  615.       lSubRtn   := .F.                  // pressed the total key reset everyting
  616.       nSavTotal := nTotal
  617.       nTotal    := 0
  618.       lTotalOk  := .T.
  619.     ENDIF
  620.   ELSE                                  // This was the first time they pressed
  621.     IF !lMultDiv .AND. LASTKEY() == K_RETURN  // total key
  622.       lSubRtn := .T.
  623.     ENDIF
  624.     IF _ftRoundIt(nTotal,nMaxDeci)!=0 .OR. _ftRoundIt(nNumTotal,nMaxDeci)!=0
  625.       IF !lMultDiv
  626.         _ftSetWinColor(W_CURR,W_SCREEN)
  627.         @ 8+nTopOS,18+nAddSpace SAY '<SUBTOTAL>'
  628.         _ftSetWinColor(W_CURR,W_PROMPT)
  629.       ENDIF
  630.       IF _ftRoundIt(nNumTotal,nMaxDeci)!=0
  631.         lSubRtn := .F.
  632.         _ftUpdateTrans(.F.,nNumTotal)
  633.       ENDIF
  634.       IF !lMultDiv
  635.         lSubRtn := .T.                  // total key
  636.       ENDIF
  637.       IF nAddMode == 1                  // Add
  638.         nTotal := nTotal+nNumTotal
  639.       ELSEIF nAddMode == 2              // Subtract
  640.         nTotal := nTotal-nNumTotal
  641.       ELSEIF nAddMode == 3              // Multiply
  642.         nTotal := nTotal*nNumTotal
  643.       ELSEIF nAddMode == 4              // Divide
  644.         nTotal := _ftDivide(nTotal,nNumTotal)
  645.         IF lDivideErr
  646.           _ftError("but you can't divide by ZERO!")
  647.           lDivideErr := .F.
  648.         ENDIF
  649.       ENDIF
  650.     ENDIF
  651.     _ftDispTotal()
  652.     IF lMultDiv                         // This was a multiply or divide
  653.       _ftSetWinColor(W_CURR,W_SCREEN)
  654.       @ 8+nTopOS,18+nAddSpace SAY '   <TOTAL>'
  655.       _ftSetWinColor(W_CURR,W_PROMPT)
  656.       lSubRtn := .F.                    // pressed the total key reset everyting
  657.       IF !lTotalOk                      // If you haven't printed total DO-IT
  658.         lTotalOk := .T.
  659.         _ftUpdateTrans(.F.)
  660.       ENDIF
  661.       nNumTotal := 0
  662.       nSavTotal := nTotal
  663.       nTotal    := 0
  664.     ELSE
  665.       IF !lTotalOk                      // If you haven't printed total DO-IT
  666.         _ftUpdateTrans(.F.)
  667.         nNumTotal := 0
  668.       ENDIF
  669.     ENDIF
  670.   ENDIF
  671. RETURN NIL
  672. **************
  673.  
  674. STATIC FUNCTION _ftAddNum(nKey)         // Process + or - keypress
  675.   lTotalOk  := .F.
  676.   lDecSet   := .F.
  677.   nDecDigit := 0
  678.   lSubRtn   := .F.
  679.   IF lMultDiv
  680.     // They pressed the + or - key to process the previous total
  681.     IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
  682.       nNumTotal := nSavTotal
  683.     ENDIF
  684.     // Get the first number of the product or division
  685.     IF _ftRoundIt(nTotal,nMaxDeci)==0
  686.       IF nKey == K_PLUS                 // Setup mode
  687.         nAddMode := 3
  688.         _ftUpdateTrans(.F.,nNumTotal)
  689.       ELSEIF nKey == K_MINUS
  690.         nAddMode := 4
  691.         _ftUpdateTrans(.F.,nNumTotal)
  692.       ENDIF
  693.       nTotal    := nNumTotal
  694.       nNumTotal := 0
  695.     ELSE
  696.       IF nKey == K_PLUS                 // Multiply
  697.         nAddMode := 3
  698.         _ftUpdateTrans(.F.,nNumTotal)
  699.         nTotal    := nTotal*nNumTotal
  700.         nNumTotal := 0
  701.       ELSEIF nKey == K_MINUS            // Divide
  702.         nAddMode := 4
  703.         _ftUpdateTrans(.F.,nNumTotal)
  704.         nTotal:=_ftDivide(nTotal,nNumTotal)
  705.         IF lDivideErr
  706.           _ftError("but you can't divide by ZERO!")
  707.           lDivideErr := .F.
  708.         ENDIF
  709.         nNumTotal := 0
  710.       ENDIF
  711.     ENDIF
  712.   ELSE
  713.     // They pressed the + or - key to process the previous total
  714.     IF _ftRoundIt(nNumTotal,nMaxDeci)==0 .AND. _ftRoundIt(nTotal,nMaxDeci)==0
  715.       nNumTotal := nSavTotal
  716.       lNewNum := .T.
  717.     ENDIF
  718.     IF nKey == K_PLUS                   // Add
  719.       nAddMode := 1
  720.       IF !lNewNum                       // They pressed + again to add the same
  721.         nNumTotal := nSavSubTotal       // number without re-entering
  722.       ENDIF
  723.       _ftUpdateTrans(.F.,nNumTotal)
  724.       nTotal := nTotal+nNumTotal
  725.       lNewNum := .F.
  726.       nSavSubTotal := nNumTotal         // Save this number in case they just press + or -
  727.       nNumTotal := 0
  728.     ELSEIF nKey == K_MINUS              // Subtract
  729.       nAddMode := 2
  730.       IF !lNewNum                       // They pressed + again to add the same
  731.         nNumTotal := nSavSubTotal       // number without re-entering
  732.         lNewNum := .T.
  733.       ENDIF
  734.       _ftUpdateTrans(.F.,nNumTotal)
  735.       nTotal    := nTotal-nNumTotal
  736.       lNewNum := .F.
  737.       nSavSubTotal := nNumTotal         // Save this number in case they just press + or -
  738.       nNumTotal := 0
  739.     ENDIF
  740.   ENDIF
  741.   _ftDispTotal()
  742. RETURN NIL
  743. **************
  744.  
  745. STATIC FUNCTION _ftAddHelp              // Help window Part of "KAW" ADDER
  746.   LOCAL nKey2
  747.   _ftPushWin(8+nTopOS,27+nLeftOS,23+nTopOS,57+nLeftOS,'INSTRUCTIONS','Any Key to Continue')
  748.   @  9+nTopOS,30+nLeftOS SAY 'All number keys as usual'
  749.   @ 10+nTopOS,30+nLeftOS SAY '<+> <-> keys as usual'
  750.   @ 11+nTopOS,30+nLeftOS SAY '<SPACE>─┬─shift <+> to <*>'
  751.   @ 12+nTopOS,30+nLeftOS SAY '        └─shift <-> to </>'
  752.   @ 13+nTopOS,30+nLeftOS SAY ' <D>    change decimal pt.'
  753.   @ 14+nTopOS,30+nLeftOS SAY ' <M>    move ADDER '
  754.   @ 15+nTopOS,30+nLeftOS SAY ' <T>    display tape'
  755.   @ 16+nTopOS,30+nLeftOS SAY ' <S>    scroll tape disp.'
  756.   @ 17+nTopOS,30+nLeftOS SAY '<DEL>───┬─1st Clear entry'
  757.   @ 18+nTopOS,30+nLeftOS SAY '        └─2nd Clear ADDER'
  758.   @ 19+nTopOS,30+nLeftOS SAY '<ESC>   to Quit'
  759.   @ 20+nTopOS,30+nLeftOS SAY '<F10>   to Return Total'
  760.   @ 21+nTopOS,30+nLeftOS SAY '          to program'
  761.   INKEY 0 TO nKey2
  762.   _ftPopWin()
  763. RETURN NIL
  764. **************
  765.  
  766. STATIC FUNCTION _ftClearAdder           // Clear entry / Clear Adder Part of "KAW" ADDER
  767.   lDecSet   := .F.
  768.   nDecDigit := 0
  769.   IF lClAdder                           // If it has alredy been pressed once
  770.     nTotal    := 0                      // then we are clearing the total
  771.     nSavTotal := 0
  772.     _ftUpdateTrans()
  773.     lClAdder := .F.
  774.     _ftDispTotal()
  775.   ELSE
  776.     nNumTotal := 0                      // Just clearing the last entry
  777.     lClAdder  := .T.
  778.     _ftDispSubTot()
  779.   ENDIF
  780. RETURN NIL
  781. **************
  782.  
  783. STATIC FUNCTION _ftDisplayTape(nKey)    // Display tape Part of "KAW" ADDER
  784.   LOCAL nDispTape
  785.   IF (nKey == 84 .OR. nKey == 116) .AND. lTape  // Stop displaying tape
  786.     lTape := .F.
  787.     RESTSCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace,cTapeScr)
  788.     RETU NIL
  789.   ENDIF
  790.   IF lTape                              // Are we in the display mode
  791.     SETCOLOR('N/W')
  792.     SCROLL(5+nTopOS,7+nTapeSpace,20+nTopOS,31+nTapeSpace,1)
  793.     IF nTotTran>0                       // Have any transactions been entered yet?
  794.       @ 20+nTopOS,7+nTapeSpace SAY aTrans[nTotTran]
  795.     ENDIF
  796.     _ftSetWinColor(W_CURR,W_PROMPT)
  797.   ELSE                                  // Start displaying tape
  798.     lTape := .T.
  799.     SETCOLOR('N/W')
  800.     cTapeScr := SAVESCREEN(4+nTopOS,6+nTapeSpace,22+nTopOS,34+nTapeSpace)
  801.     _ftShadow(22+nTopOS,8+nTapeSpace,22+nTopOS,34+nTapeSpace)
  802.     _ftShadow(5+nTopOS,33+nTapeSpace,21+nTopOS,34+nTapeSpace)
  803.     SETCOLOR('R+/W')
  804.     @ 4+nTopOS,6+nTapeSpace,21+nTopOS,32+nTapeSpace BOX B_SINGLE
  805.     SETCOLOR('GR+/W')
  806.     @ 4+nTopOS,17+nTapeSpace SAY ' TAPE '
  807.     SETCOLOR('N/W')
  808.     IF nTotTran>15
  809.       nTopTape := nTotTran-15
  810.     ENDIF
  811.     FOR nDispTape=nTotTran TO nTopTape STEP -1
  812.       @ 20+nDispTape-nTotTran+nTopOS,7+nTapeSpace SAY aTrans[nDispTape]
  813.     NEXT
  814.   ENDIF
  815.   _ftSetWinColor(W_CURR,W_PROMPT)
  816. RETURN NIL
  817. **************
  818.  
  819.  
  820. STATIC FUNCTION _ftUpdateTrans(lTypeTotal,nAmount)  // Update transactions array Part of "KAW" ADDER
  821.   nAmount := IF(nAmount==NIL,0,nAmount)
  822.   IF lClAdder                           // Clear the adder (they pressed <DEL> twice
  823.     AADD(aTrans,STR(0,20,nMaxDeci)+' C') 
  824.     IF lTape                            // If there is a tape Show Clear
  825.       _ftDisplayTape()
  826.     ENDIF
  827.     RETU NIL
  828.   ENDIF
  829.   IF lTypeTotal                         // If lTypeTotal=.T. Update from total
  830.     AADD(aTrans,STR(IF(PCOUNT()==1,nTotal,nAmount),20,nMaxDeci)+' *')
  831.     aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran],.T.)+IF(lAddError,'ER','')
  832.   ELSE                                  // If lTypeTotal=.F. Update from nNumTotal
  833.     AADD(aTrans,STR(IF(PCOUNT()==1,nTotal,nAmount),20,nMaxDeci)+;
  834.       IF(lSubRtn,' ',IF(nAddMode==1,' +',IF(nAddMode==2,' -',IF;
  835.       (lTotalOk,' =',IF(nAddMode==3,' X',' ÷'))))))
  836.     aTrans[nTotTran] := _ftStuffComma(aTrans[nTotTran],.T.)+IF(lAddError,'ER','')
  837.   ENDIF
  838.   IF lTape
  839.     _ftDisplayTape()
  840.   ENDIF
  841. RETURN NIL
  842. **************
  843.  
  844.  
  845. FUNCTION __ftAdderTapeUDF(mode,cur_elem,rel_pos)  // User function for ACHOICE in "KAW" ADDER
  846.   LOCAL nKey,nRtnVal
  847.   STATIC ac_exit_ok := .F.
  848.   DO CASE
  849.     CASE mode == AC_EXCEPT
  850.       nKey := LASTKEY()
  851.       DO CASE
  852.         CASE nKey == 30
  853.           nRtnVal := AC_CONT
  854.         CASE nKey == K_ESC
  855.           KEYBOARD CHR(K_CTRL_PGDN)+CHR(K_RETURN)  // Go to last item
  856.           ac_exit_ok := .T.
  857.           nRtnVal := AC_CONT
  858.         CASE ac_exit_ok
  859.           nRtnVal := AC_ABORT
  860.           ac_exit_ok := .F.
  861.         OTHERWISE
  862.           nRtnVal := AC_CONT
  863.       ENDCASE
  864.     OTHERWISE
  865.       nRtnVal := AC_CONT
  866.   ENDCASE
  867. RETURN nRtnVal
  868. *************
  869.  
  870.  
  871. STATIC FUNCTION _ftValDeci(oGet)
  872.   IF oGet:VarGet()>8 
  873.     _ftError('no more than 8 decimal places please!')
  874.     RETU .F.
  875.   ENDIF
  876. RETURN .T.
  877. *************
  878.  
  879.  
  880. STATIC FUNCTION _ftDivide(nNumerator,nDenominator)  // Check divide by zero not allowed
  881.   IF nDenominator==0.0
  882.     lDivideErr := .T.
  883.     RETU 0
  884.   ELSE
  885.     lDivideErr := .F.
  886.   ENDIF
  887. RETURN(nNumerator/nDenominator)
  888. **************
  889.  
  890.  
  891. STATIC FUNCTION _ftStuffComma(cStrToStuff,lTrimStuffedStr)  // Stuff comma into tape display Part of "KAW" ADDER
  892.   LOCAL nDecPosit,x
  893.   lTrimStuffedStr := IF(lTrimStuffedStr=NIL,.F.,lTrimStuffedStr)
  894.   IF !('.' $ cStrToStuff)
  895.     cStrToStuff := _ftPosIns(cStrToStuff,'.',IF('C'$cStrToStuff .OR. 'E'$cStrToStuff;
  896.       .OR. '+'$cStrToStuff .OR. '-'$cStrToStuff .OR. 'X'$cStrToStuff .OR. ;
  897.       '*'$cStrToStuff .OR. ''$cStrToStuff .OR. '÷'$cStrToStuff .OR. '='$cStrToStuff,;
  898.       LEN(cStrToStuff)-1,LEN(cStrToStuff)+1))
  899.   ENDIF
  900.   nDecPosit := AT('.',cStrToStuff)
  901.   IF LEN(LEFT(LTRIM(_ftCharRem('-',cStrToStuff)),;
  902.       AT('.',LTRIM(_ftCharRem('-',cStrToStuff)))-1))>3
  903.     IF lTrimStuffedStr                  // Do we trim the number each time we insert a comma
  904.       FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -4
  905.         cStrToStuff := SUBSTR(_ftPosIns(cStrToStuff,',',x),2)
  906.       NEXT
  907.     ELSE
  908.       FOR x=nDecPosit-3 TO 2+_ftCountLeft(cStrToStuff,' ') STEP -3
  909.         cStrToStuff := _ftPosIns(cStrToStuff,',',x)
  910.       NEXT
  911.     ENDIF
  912.   ENDIF
  913. RETURN(cStrToStuff)
  914. **************
  915.  
  916.  
  917. STATIC FUNCTION _ftEraseTotSubTot
  918.   _ftSetWinColor(W_CURR,W_SCREEN)
  919.   @ 8+nTopOS,18+nAddSpace SAY '          '  // Clear <TOTAL> - <SUBTOTAL>
  920.   _ftSetWinColor(W_CURR,W_PROMPT)
  921. RETURN NIL
  922. *************
  923.  
  924.  
  925. *****  "KAW Adder Support functions  *******
  926.  
  927. STATIC FUNCTION _ftRingBell(lMustRing)  // I can turn off the bell!
  928.   lMustRing := IF(lMustRing == NIL, .F., lMustRing)
  929.   IF lMustRing .OR. lStatMustRing
  930.     ?? CHR(7)
  931.   ENDIF
  932. RETURN NIL
  933. **************
  934.  
  935.  
  936. STATIC FUNCTION _ftError(cMessage)      // Print error messages
  937.   LOCAL nOldRow,nOldCol,nOldCurs,nTop,nLeft,nBot,nRight,cOldColor
  938.   LOCAL nOldLastKey,cErrorScr,nMessLen,nWide,nNumRows
  939.   nOldLastKey := LASTKEY()
  940.   nOldRow  := ROW()
  941.   nOldCol  := COL()
  942.   nOldCurs := SETCURSOR(SC_NONE)
  943.   cOldColor:= _ftSetScrColor(STD_ERROR)
  944.   cMessage := "I'm sorry but, "+cMessage
  945.   nMessLen := LEN(cMessage)
  946.   nWide    := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
  947.   nNumRows := MLCOUNT(cMessage,nWide)
  948.   nTop     := 15-nNumRows
  949.   nBot     := nTop+3+nNumRows
  950.   nLeft    := 40-_ftRoundIt(nWide/2,0)-2
  951.   nRight   := nLeft+nWide+4
  952.  
  953.   cErrorScr:=SAVESCREEN(nTop,nLeft,nBot+1,nRight+2)
  954.   _ftShadow(nBot+1,nLeft+2,nBot+1,nRight+2,8)
  955.   _ftShadow(nTop+1,nRight+1,nBot  ,nRight+2,8)
  956.   @ nTop,nLeft,nBot,nRight BOX B_SINGLE
  957.   @ nTop,nLeft+INT(nWide/2)-1 SAY ' ERROR '
  958.   @ nBot-1,nLeft+INT(nWide-28)/2+3 SAY 'Press any key to continue...'
  959.   DISPMESSAGE cMessage,nTop+1,nLeft+3,nBot-2,nRight-3
  960.   TONE(70,5)
  961.   INKEY(0)
  962.   RESTSCREEN(nTop,nLeft,nBot+1,nRight+2,cErrorScr)
  963.   SETCURSOR(nOldCurs)
  964.   SETCOLOR(cOldColor)
  965.   SETPOS(nOldRow,nOldCol)
  966.   _ftSetLastKey(nOldLastKey)
  967. RETURN NIL
  968. **************
  969.  
  970.  
  971. STATIC FUNCTION _ftCountLeft(cString,dummy) // Returns the number of spaces on
  972. RETURN(LEN(cString)-LEN(LTRIM(cString)))    // the Left side of the String
  973. **************
  974.  
  975.  
  976. STATIC FUNCTION _ftPosRepl(cString,cChar,posit)  // Replace a Character in a
  977. RETURN(STRTRAN(cString,'9',cChar,posit,1)+'')    // String
  978. **************
  979.  
  980.  
  981. STATIC FUNCTION _ftPosIns(cString,cChar,posit)    // Insert a Character in a
  982. RETURN(LEFT(cString,posit-1)+cChar+SUBSTR(cString,posit))  // String
  983. **************
  984.  
  985.  
  986. STATIC FUNCTION _ftCharRem(cChar,cString)  // Removes character from string
  987. RETURN(STRTRAN(cString,cChar))
  988. **************
  989.  
  990. /* _ftQuestion(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop,cHelp) ;
  991. *           -->xVarVal
  992. *
  993. *    Push a Question Box on the screen and get the answer with a local
  994. *    variable, and return their answer
  995. *
  996. *    cMessage  -> Message printed above variable that describes explains
  997. *                    what they are getting
  998. *    xVarVal   -> Initial value of the variable Data types C,N,L,D
  999. *    cPict     -> Picture for GET                              - Optional
  1000. *    bValid    -> Valid Block                                  - Optional
  1001. *    lNoESC    -> When .T. they cannot <ESC>, default .F.      - Optional
  1002. *    nWinColor -> Window color, default next window color      - Optional
  1003. *    nTop      -> Top row of window, default Center of screen  - Optional
  1004. *    cHelp     -> If passed pushes the specific help variable to help stack
  1005. *                 If Not passed pushes the variable name 'NOQuHelp'  - Opt.
  1006. */
  1007.  
  1008. STATIC FUNCTION _ftQuestion(cMessage,xVarVal,cPict,bValid,lNoESC,nWinColor,nTop)
  1009.  
  1010.   LOCAL nOldRow, nOldCol, cOldColor, nMessLen, nWide, nNumRows, nBottom, nLeft
  1011.   LOCAL nRight, oNewGet, nNumMessRow, nLenLastRow, lGetOnNextLine, nOldCurs
  1012.   LOCAL cVarType := VALTYPE(xVarVal)
  1013.   LOCAL nVarLen  := IF(cVarType='C',LEN(xVarVal),IF(cVarType='D',8, ;
  1014.                        IF(cVarType='L',1,IF(cVarType='N',IF(cPict=NIL,9, ;
  1015.                        LEN(cPict)),0))))
  1016.   LOCAL nOldLastKey := LASTKEY()
  1017.   MEMVAR GETLIST  
  1018.  
  1019.   nOldRow   := ROW()
  1020.   nOldCol   := COL()
  1021.   nOldCurs  := SETCURSOR(SC_NONE)
  1022.   cOldColor := SETCOLOR()
  1023.   lNoESC    := IF(lNoESC==NIL,.F.,lNoESC)
  1024.  
  1025.   nMessLen  := LEN(cMessage)+nVarLen+1
  1026.   nWide     := IF(nMessLen>66,66,IF(nMessLen<12,12,nMessLen))
  1027.  
  1028.   nNumMessRow    := MLCOUNT(cMessage,nWide)
  1029.   nLenLastRow    := LEN(TRIM(MEMOLINE(cMessage,nWide,nNumMessRow)))
  1030.   lGetOnNextLine := (nLenLastRow + nVarLen) > nWide
  1031.   nNumRows       := nNumMessRow + IF(lGetOnNextLine,1,0)
  1032.  
  1033.   nTop        := IF(nTop=NIL,INT((MAXROW() - nNumRows)/2),nTop)  // Center it in the screen
  1034.   nBottom     := nTop+nNumRows+1
  1035.   nLeft       := INT((MAXCOL()-nWide)/2)-4
  1036.   nRight      := nLeft+nWide+4
  1037.  
  1038.   _ftPushWin(nTop,nLeft,nBottom,nRight,'QUESTION ?',IF(VALTYPE(xVarVal)='C' ;
  1039.           .AND. nVarLen>nWide,CHR(27)+' scroll '+ CHR(26),NIL),nWinColor)
  1040.   DISPMESSAGE cMessage,nTop+1,nLeft+2,nBottom-1,nRight-2
  1041.  
  1042.   oNewGet := GetNew( IF(lGetOnNextLine,Row()+1,Row()), ;
  1043.                      IF(lGetOnNextLine,nLeft+2,Col()+1), ;
  1044.                      {|x| IF(PCOUNT() > 0, xVarVal := x, xVarVal)}, ;
  1045.                      'xVarVal' )
  1046.  
  1047.   // If the input line is character & wider than window SCROLL
  1048.   IF lGetOnNextLine .AND. VALTYPE(xVarVal)='C' .AND. nVarLen>nWide
  1049.     oNewGet:Picture   := '@S'+LTRIM(STR(nWide,4,0))+IF(cPict=NIL,'',' '+cPict)
  1050.   ENDIF
  1051.  
  1052.   IF cPict != NIL                       // Use the picture they passed
  1053.     oNewGet:Picture   := cPict
  1054.   ELSE                                  // Else setup default pictures
  1055.     IF VALTYPE(xVarVal)='D'
  1056.       oNewGet:Picture   := '99/99/99'
  1057.     ELSEIF VALTYPE(xVarVal)='L'
  1058.       oNewGet:Picture   := 'Y'
  1059.     ELSEIF VALTYPE(xVarVal)='N'
  1060.       oNewGet:Picture   := '999999.99'  // Guess that they are inputting dollars
  1061.     ENDIF
  1062.   ENDIF
  1063.  
  1064.   oNewGet:PostBlock := IF(bValid=NIL,NIL,bValid)
  1065.  
  1066.   oNewGet:Display()
  1067.  
  1068.   _ftRingBell()
  1069.  
  1070.   DO WHILE .T.                          // Loop so we can check for <ESC>
  1071.                                         // without reissuing the gets
  1072.     ReadModal({oNewGet})
  1073.     IF LASTKEY() == K_ESC .AND. lNoESC  // They pressed <ESC>
  1074.       _ftError('you cannot Abort! Please enter an answer.')
  1075.     ELSE
  1076.       EXIT
  1077.     ENDIF
  1078.  
  1079.   ENDDO
  1080.  
  1081.   _ftPopWin()
  1082.  
  1083.   SETCURSOR(nOldCurs)
  1084.   SETCOLOR(cOldColor)
  1085.   SETPOS(nOldRow,nOldCol)
  1086.   _ftSetLastKey(nOldLastKey)
  1087. RETURN xVarVal
  1088.  
  1089.  
  1090. /* _ftSetLastKey(nLastKey) -- NIL
  1091. *   Sets the LASTKEY() value to the vlaue nLastKey. I use this in most of my
  1092. *   Pop-Up routines to reset the origional value of LASTKEY() when quitting.
  1093. *
  1094. */
  1095.  
  1096. STATIC FUNCTION _ftSetLastKey(nLastKey)
  1097.   _ftPushKeys()
  1098.   KEYBOARD CHR(nLastKey)
  1099.   INKEY()
  1100.   _ftPopKeys()
  1101. RETURN NIL
  1102. ***************
  1103.  
  1104.  
  1105. /*  _ftPushKeys --> NIL
  1106.  *  Push any keys in the Keyboard buffer on the array aKeys[]
  1107.  */
  1108.  
  1109. STATIC FUNCTION _ftPushKeys
  1110.   DO WHILE NEXTKEY() != 0
  1111.     AADD(aKeys,INKEY())
  1112.   ENDDO
  1113. RETURN NIL
  1114.  
  1115.  
  1116. /*  _ftPopKeys() --> NIL
  1117.  *  Restore the keyboard with any keystrokes that were saved with _ftPushKeys
  1118.  */
  1119.  
  1120. STATIC FUNCTION _ftPopKeys
  1121.   LOCAL cKeys := ''
  1122.   IF LEN(aKeys) != 0
  1123.     AEVAL(aKeys, {|elem| cKeys += CHR(elem)})
  1124.   ENDIF
  1125.   KEYBOARD cKeys
  1126.   aKeys := {}
  1127. RETURN NIL
  1128.  
  1129.  
  1130. /* _ftActiveWinNum() --> nWinColor
  1131. *    Return the currently active window color nWinColor which is a STATIC 
  1132. *    variable in the WINDOW.PRG. This gives access to any routine using 
  1133. *    windows.
  1134. *    */
  1135. STATIC FUNCTION _ftActiveWinNum
  1136. RETURN(nWinColor)
  1137. **************
  1138.  
  1139.  
  1140. /* _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel) --> cOldColor
  1141. *    Set the screen colors to the colors requested for the window
  1142. *    requested. If the window number is not passed use the currently active
  1143. *    window number nWinColor. 
  1144. *    */
  1145. STATIC FUNCTION _ftSetWinColor(nWin,nStd,nEnh,nBord,nBack,nUnsel)
  1146.   nWin  := IF(nWin=NIL,nWinColor,nWin)
  1147.   nStd  := IF(nStd=NIL,7,nStd)
  1148.   nEnh  := IF(nEnh=NIL,7,nEnh)
  1149.   nBord := IF(nBord=NIL,7,nBord)
  1150.   nBack := IF(nBack=NIL,7,nBack)
  1151.   nUnsel:= IF(nUnsel=NIL,nEnh,nUnsel)
  1152. RETURN SETCOLOR(aWinColor[nStd,nWin]+','+aWinColor[nEnh,nWin]+','+;
  1153.   aWinColor[nBord,nWin]+','+aWinColor[nBack,nWin]+','+aWinColor[nUnsel,nWin])
  1154. **************
  1155.  
  1156.  
  1157. /* _ftSetSCRColor(nStd,nEnh,nBord,nBack,nUnsel) --> cOldColor
  1158.  *   Set the standard screen colors to the color requested.
  1159.  *   */
  1160. STATIC FUNCTION _ftSetScrColor(nStd,nEnh,nBord,nBack,nUnsel)
  1161.   nStd  := IF(nStd=NIL,8,nStd)
  1162.   nEnh  := IF(nEnh=NIL,8,nEnh)
  1163.   nBord := IF(nBord=NIL,8,nBord)
  1164.   nBack := IF(nBack=NIL,8,nBack)
  1165.   nUnsel:= IF(nUnsel=NIL,nEnh,nUnsel)
  1166. RETURN SETCOLOR(aStdColor[nStd]+','+aStdColor[nEnh]+','+aStdColor[nBord]+','+;
  1167.   aStdColor[nBack]+','+aStdColor[nUnsel])
  1168. **************
  1169.  
  1170.  
  1171. /* _ftSetBordColor(nBorder) --> cOldColor
  1172. *    Set the Color to the Border color they requested and return the previous
  1173. *    color setting.
  1174. *    */
  1175. STATIC FUNCTION _ftSetBordColor(nBorder)
  1176. RETURN SETCOLOR(aStdcolor[8,nBorder])
  1177. **************
  1178.  
  1179.  
  1180. /* _ftNextWinColor() --> nWinColor
  1181. *    Increment the active window color number and return the current value.
  1182. *    If we are already on window #4 restart count by using # 1.
  1183. *    */
  1184. STATIC FUNCTION _ftNextWinColor
  1185. RETURN nWinColor := (IF(nWinColor<4,nWinColor+1,1))
  1186. **************
  1187.  
  1188.  
  1189. /* _ftLastWinColor() --> nWinColor
  1190. *    Decrement the active window color number and return the current value.
  1191. *    If we are already on window #1 restart count by using # 4.
  1192. *    */
  1193. STATIC FUNCTION _ftLastWinColor
  1194. RETURN nWinColor := IF(nWinColor=1,4,nWinColor-1)
  1195. *******************
  1196.  
  1197.  
  1198. /* _ftPushWin(t,l,b,r,cTitle,cBotTitle,w_color,cTypeBord) --> NIL
  1199. *    Push a new window on the screen in the position t,l,b,r and if cTitle
  1200. *    is not NIL print the title for the window in centered in the top line
  1201. *    of the box. Simillarly do the same for cBotTitle. If w_color=NIL get
  1202. *    the next window color and use it for all the colors. If cTypeBord=NIL
  1203. *    use the single line border, else use the one they requested. Push the
  1204. *    window coordinates, the color number, the SAVESCREEN() value, and
  1205. *    whether they picked the window color they wanted to use. 
  1206. *    If lAutoWindow=.F. then the window color was incremented and we will
  1207. *    will restore the color number when we pop the window off.
  1208. *    */
  1209. STATIC FUNCTION _ftPushWin(t,l,b,r,cTitle,cBotTitle,w_color,cTypeBord)
  1210.   LOCAL lAutoWindow := IF(w_color=NIL,.T.,.F.)
  1211.   w_color := IF(w_color=NIL,_ftNextWinColor(),w_color)
  1212.   AADD(aWindow,{t,l,b,r,w_color,SAVESCREEN(t,l,b+1,r+2),lAutoWindow})
  1213.   _ftShadow(b+1,l+2,b+1,r+2)
  1214.   _ftShadow(t+1,r+1,b,r+2)
  1215.   _ftSetWinColor(w_color,W_BORDER)
  1216.   @ t,l,b,r BOX IF(cTypeBord=NIL,B_SINGLE,cTypeBord)
  1217.   IF cTitle!=NIL
  1218.     _ftSetWinColor(w_color,W_TITLE)
  1219.     _ftWinTitle(cTitle)
  1220.   ENDIF
  1221.   IF cBotTitle!=NIL
  1222.     _ftSetWinColor(w_color,W_TITLE)
  1223.     _ftWinTitle(cBotTitle,'bot')
  1224.   ENDIF
  1225.   _ftSetWinColor(w_color,W_SCREEN,W_VARIAB)
  1226.   @ t+1,l+1 CLEAR TO b-1,r-1
  1227. RETURN NIL
  1228. *******************
  1229.  
  1230.  
  1231. /* _ftPopWin() --> NIL
  1232. *    Pop the currently active window off the screen by restoring it from the
  1233. *    aWindow Array and if they pushed a new window automatically selecting the
  1234. *    color we will roll back the current window setting using _ftLastWinColor()
  1235. *    and reset the color to the color setting when window was
  1236. *    pushed.
  1237. *    */
  1238. STATIC FUNCTION _ftPopWin
  1239.   LOCAL nNumWindow:=LEN(aWindow)
  1240.   RESTSCREEN(aWindow[nNumWindow,1],aWindow[nNumWindow,2],aWindow[nNumWindow,3]+1,;
  1241.   aWindow[nNumWindow,4]+2,aWindow[nNumWindow,6])
  1242.   IF aWindow[nNumWindow,7]
  1243.     _ftLastWinColor()
  1244.   ENDIF
  1245.   ASHRINK(aWindow)
  1246.   IF !EMPTY(aWindow)
  1247.     _ftSetWinColor(W_CURR,W_SCREEN,W_VARIAB)
  1248.   ELSE
  1249.     _ftSetScrColor(STD_SCREEN,STD_VARIABLE)
  1250.   ENDIF
  1251. RETURN NIL
  1252. *******************
  1253.  
  1254.  
  1255. /* _ftWinTitle(cTheTitle,cTopOrBot) --> NIL
  1256. *    Print the top or bottom titles on the border of the currently active
  1257. *    window.
  1258. *    */
  1259. STATIC FUNCTION _ftWinTitle(cTheTitle,cTopOrBot)
  1260.   LOCAL nCurWin  :=LEN(aWindow)
  1261.   LOCAL nLenTitle:=LEN(cTheTitle)
  1262.   @ aWindow[nCurWin,IF(cTopOrBot=NIL,1,3)],(aWindow[nCurWin,4]-;
  1263.   aWindow[nCurWin,2]-nLenTitle)/2+aWindow[nCurWin,2] SAY ' '+cTheTitle+' '
  1264. RETURN NIL
  1265. *******************
  1266.  
  1267.  
  1268. /* _ftShadow(nTop,nLeft,nBottom,nRight) --> NIL
  1269. *    Create a shaddow on the screen in the coordinates given
  1270. *    */
  1271. STATIC FUNCTION _ftShadow( nTop, nLeft, nBottom, nRight )
  1272.   LOCAL theShadow := SAVESCREEN(nTop, nLeft, nBottom, nRight)
  1273.   RESTSCREEN( nTop, nLeft, nBottom, nRight,;
  1274.   TRANSFORM( theShadow,REPLICATE("X", LEN(theShadow)/2 ) ) )
  1275. RETURN NIL
  1276. **************
  1277.  
  1278.  
  1279. STATIC FUNCTION _ftRoundIt(nNumber, nPlaces)  // Replacement ROUND()
  1280.   nPlaces := IF( nPlaces == NIL, 0, nPlaces )
  1281. RETURN IF(nNumber < 0.0, -1.0, 1.0) * ;
  1282.        INT( ABS(nNumber) * 10 ^ nPlaces + 0.50 + 10 ^ -12 ) / 10 ^ nPlaces
  1283. *************
  1284.  
  1285.  
  1286. STATIC FUNCTION _ftCharOdd(cString)   // Return the ODD characters from string
  1287.   cString := TRANSFORM(cString,REPLICATE("X", LEN(cString)/2 ) )
  1288. RETURN STRTRAN(cString,'')
  1289. **************
  1290.  
  1291.  
  1292.