home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / PICKLIST.PRG < prev    next >
Text File  |  1993-02-23  |  68KB  |  1,839 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program..: PICKLIST.PRG 
  3. *-- Date.....: 02/23/1993
  4. *-- Notes....: This new (as of November, 1992) section of the DUFLP library is
  5. *--            designed to be a place where a variety of picklist routines
  6. *--            will be stored. You can ... ahem ... pick and choose the one(s)
  7. *--            you need from here.
  8. *-- WARNING..: Do not save changes with WordStar 5.5 Non_Document mode --
  9. *--            the diacritical characters in the DIACRIT procedure below
  10. *--            will not be saved properly (WordStar doesn't like high ASCII 
  11. *--            characters ...)
  12. *-------------------------------------------------------------------------------
  13.  
  14. FUNCTION Pick1
  15. *-------------------------------------------------------------------------------
  16. *-- Programmer..: Kenneth W. Holloway (HollowayK on BORBBS)
  17. *-- Date........: 02/22/1993
  18. *-- Notes.......: Pick List.
  19. *-- Written for.: dBASE IV, 1.5
  20. *-- Rev. History: 08/12/1992 0.0 - Original version (KWH)
  21. *--               09/11/1992 0.1 - (KWH) Added color settings (x_ClrP*) that
  22. *--                                 were Ass-U-Med to be defined elsewhere.
  23. *--               09/16/1992 0.2 - (KWH) Added "set key to" at end of function.
  24. *--                                 (BORLAND: What happened to set("KEY")?!?!)
  25. *--               10/14/1992 0.3 - Added (KenMayer) ability to pass colors
  26. *--                                to program ... removed settings for
  27. *--                                alias, order, key. The reason is a lack
  28. *--                                of stack space to call routine, can only send
  29. *--                                x number of parms. The programmer must
  30. *--                                set the database (select .../Use ...), 
  31. *--                                order, and key (set key...) before calling
  32. *--                                this routine, and then reset to prior setting
  33. *--                                (if needed). 
  34. *--               10/15/1992 0.4 - (KWH) Added code for Tab/Shift Tab. Put the
  35. *--                                 setting for key back in, as it is required
  36. *--                                 for proper SEEKing with SET KEY in effect.
  37. *--               10/19/1992 0.5 - (KWH) Several changes inspired by JOEY:
  38. *--                 ■ Now uses setting of SET BORDER TO when drawing borders.
  39. *--                 ■ Bell only sounds when SET BELL is ON.
  40. *--                 ■ Added code for {Home} and {End}.
  41. *--               11/06/1992 0.6 - (KWH) Optimization inspired by KELVIN:
  42. *--                 ■ Removed repetitive recalculation of PICTURE clause
  43. *--                 ■ Removed some dead code
  44. *--                 ■ Added a logical variable for main loop, instead of four
  45. *--                     .and.ed expressions
  46. *--               02/22/1993 -- Minor change to PRIVATE calls.
  47. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  48. *-- Called by...: Any
  49. *-- Usage.......: Pick1(cTitle,cDisplay,cReturn[,cKey[,nFromRow,nFromCol
  50. *--                           [,nToRow,nToCol[,cColor1[,cColor2]]]]])
  51. *-- Example.....: ? Pick1("Client Name","NAME","JOB_CODE","",5,10,20,55,;
  52. *--                          cColor1,cColor2)
  53. *-- Returns.....: Specified expression, using macro substitution.
  54. *-- Parameters..: cTitle    = Title to be displayed above PickList
  55. *--               cDisplay  = Expression to display, using macro substitution
  56. *--                 Note: If cDisplay includes any chr(29)'s (), the Tab and
  57. *--                       Shift Tab keys can be used to highlight/unhighlight
  58. *--                       everything up to the next/previous chr(29).
  59. *--               cReturn   = Expression to return, using macro substitution
  60. *--               cKey      = Expression for SET KEY TO
  61. *--               nFromRow  \ Upper left corner
  62. *--               nFromCol  / of PickList window
  63. *--               nToRow    \ Lower right corner
  64. *--               nToCol    / of PickList window
  65. *--               cColor1   = message,title,box 
  66. *--               cColor2   = highlight,selected
  67. *--                           Both cColor1, and cColor2 use specific color
  68. *--                           settings of <Foreground>/<Background>  for each
  69. *--                           part of the parm. For example, cColor1 might
  70. *--                           look like:  rg+/gb,w+/b,rg+/gb
  71. *--                           Definitions:
  72. *--                            message   = unselected items in picklist (w+/rb)
  73. *--                            title     = title at top of window (w+/rb)
  74. *--                            box       = border (rg+/rb)
  75. *--                            highlight = highlighted item (g+/n)
  76. *--                            selected  = selected character(s) (r+/n)
  77. *-------------------------------------------------------------------------------
  78.  
  79.   parameters  cTitle,cDisplay,cReturn,;
  80.               cKey,;
  81.               nFromRow,nFromCol,nToRow,nToCol,;
  82.               cColor1, cColor2
  83.   private all except _p*
  84.  
  85.   * Check validity of all parameters
  86.   if pcount()<3
  87.     return "***"+program()+" Error***"
  88.   endif
  89.  
  90.   * Save setting of TALK and turn it off.
  91.   if set("TALK")="ON"
  92.     set talk off
  93.     cTalk     = "ON"
  94.    else
  95.     cTalk     = "OFF"
  96.   endif
  97.  
  98.   * Save and change settings of other parameters
  99.   cConsole    = set("CONSOLE")
  100.   cCursor     = set("CURSOR")
  101.   cEscape     = set("ESCAPE")
  102.   set cursor        off
  103.   set escape        off
  104.  
  105.   * Set default values for unspecified parameters
  106.   if type("cKey")="L"
  107.     cKey      = ""
  108.   endif
  109.   if type("nFromRow")="L"
  110.     nFromRow  = 5
  111.   endif
  112.   if type("nFromCol")="L"
  113.     nFromCol  = 5
  114.   endif
  115.  
  116.   if type("cColor1")="L"
  117.       x_ClrPMess  = "W+/RB"
  118.       x_ClrPTitl  = "W+/RB"
  119.       x_ClrPBox   = "RG+/RB"
  120.   else
  121.      x_ClrPMess  = colorbrk(cColor1,1)
  122.      x_ClrPTitl  = colorbrk(cColor1,2)
  123.      x_ClrPBox   = colorbrk(cColor1,3) 
  124.   endif
  125.   if type("cColor2")="L"
  126.      x_ClrPHigh  = "G+/N"
  127.      x_ClrPSlct  = "R+/N"
  128.   else
  129.      x_ClrPHigh  = colorbrk(cColor2,1)
  130.      x_ClrPSlct  = colorbrk(cColor2,2)
  131.   endif
  132.  
  133.   *-- Real code starts here
  134.   * Setup specified database environment
  135.   if .not.isblank(cKey)
  136.     set key to cKey
  137.   endif
  138.  
  139.   * Calculate value of nToRow
  140.   if type("nToRow")="L"
  141.     goto top
  142.     count to nToRow next 21-nFromRow
  143.     nToRow    = nFromRow + max(nToRow,3) + 3
  144.   endif
  145.  
  146.   * Calculate value of nToCol
  147.   if type("nToCol")="L"
  148.     nToCol    = nFromCol + max(len(cTitle),len(&cDisplay.)) + 1
  149.     if nToCol>79
  150.       nToCol  = 79
  151.     endif
  152.   endif
  153.  
  154.   * Define and activate title window, draw border and title
  155.   define window wPickList1 from nFromRow,nFromCol to nToRow,nToCol none ;
  156.     color &x_ClrPMess.
  157.   activate window wPickList1
  158.   nWindRow  = nToRow - nFromRow
  159.   nWindCol  = nToCol - nFromCol
  160.   @ 00,00 to nWindRow,nWindCol  color &x_ClrPBox.
  161.   @ 01,01 say cTitle            color &x_ClrPTitl.
  162.   @ 02,01 to 02,nWindCol-1      color &x_ClrPBox.
  163.   cBorder = set("BORDER")
  164.   do case
  165.     case cBorder="NONE"
  166.     case cBorder="SINGLE"
  167.       @ 02,00       say "├"                             color &x_ClrPBox.
  168.       @ 02,nWindCol say "┤"                             color &x_ClrPBox.
  169.     case cBorder="DOUBLE"
  170.       @ 02,00       say "╠"                             color &x_ClrPBox.
  171.       @ 02,nWindCol say "╣"                             color &x_ClrPBox.
  172.     case cBorder="PANEL"
  173.       @ 02,00       say "█"                             color &x_ClrPBox.
  174.       @ 02,nWindCol say "█"                             color &x_ClrPBox.
  175.     otherwise
  176.       @ 02,00       say chr(val(substr(cBorder,17,3)))  color &x_ClrPBox.
  177.       @ 02,nWindCol say chr(val(substr(cBorder,21,3)))  color &x_ClrPBox.
  178.   endcase
  179.  
  180.   * Define and activate data window
  181.   define window wPickList2 from nFromRow+3,nFromCol+1 to nToRow-1,nToCol-1 none color &x_ClrPMess.
  182.   activate window wPickList2
  183.   nWindRow  = nToRow - nFromRow-4
  184.   nWindCol  = nToCol - nFromCol-2
  185.   cWindPict = replicate('X',nWindCol+1)
  186.  
  187.   * Initialize position and status variables
  188.   goto top
  189.   lBell     = (set("BELL")="ON")
  190.   nCurRow   = 0
  191.   nInkey    = 0
  192.   nNewRow   = 0
  193.   nRecNo    = recno()
  194.   lRepaint  = .t.
  195.   cSeek     = ""
  196.   lSeek     = .F.
  197.   nNewSCur  = 0
  198.   nSeekCur  = 0
  199.   if eof()
  200.     if lBell
  201.       @ 00,00 say chr(7)
  202.     endif
  203.     @ 00,00 say "*** No records to list ***"
  204.     set console off
  205.     wait
  206.     set console on
  207.     cReturn = ""
  208.     nInkey  = 27
  209.   endif
  210.  
  211.  
  212.   *-- Display PickList until Enter .or. Ctrl-Q .or. Ctrl-W or Ctrl-End
  213.   *-- .or. Esc is pressed
  214.   lMore = .T.
  215.   do while lMore
  216.     if lSeek
  217.       seek cKey+cSeek
  218.       nNewSCur    = len(cSeek)
  219.       cStr        = &cDisplay.
  220.       nPos  = at(chr(29),substr(cStr,1,nNewSCur+1))
  221.       do while nPos>0
  222.         cStr      = stuff(cStr,nPos,1," ")
  223.         nNewSCur  = nNewSCur + 1
  224.         nPos      = at(chr(29),substr(cStr,1,nNewSCur+1))
  225.       enddo
  226.       nSeek = recno()                   && Save new record number
  227.       n     = 0                         && Counter
  228.       goto nRecNo                       && Record at top of screen
  229.       * Look to see if new record is on screen
  230.       scan while recno()#nSeek .and. n<nMaxRow
  231.         n = n + 1
  232.       endscan
  233.       if recno()=nSeek                  && New record is on screen
  234.         nNewRow = n                     && Put cursor on new record
  235.        else                             && New record is not on screen
  236.         nNewRow   = 0                   && Put cursor at top of window
  237.         nRecNo    = nSeek               && New record at top of window
  238.         lRepaint  = .T.                 && Redisplay window
  239.       endif
  240.       lSeek = .F.
  241.     endif
  242.  
  243.     if lRepaint .or. nNewRow#nCurRow
  244.       * Hide cursor
  245.       @ nCurRow,00 fill to nCurRow,nWindCol color &x_ClrPMess.
  246.     endif
  247.  
  248.     if lRepaint         && Need to redisplay entire data window
  249.       goto nRecNo                       && Record that should be at top of window
  250.       nMaxRow = 0                       && Number of rows displayed
  251.       scan while nMaxRow<=nWindRow      && nWindRow = number of rows in window
  252.         * Display data
  253.         @ nMaxRow,00 say &cDisplay. picture cWindPict color &x_ClrPMess.
  254.         nMaxRow = nMaxRow + 1           && Increase rows displayed counter
  255.       endscan
  256.       nMaxRow = nMaxRow - 1             && Make rows displayed counter zero-based
  257.  
  258.       if eof() .and. nMaxRow<nWindRow   && Didn't fill window?
  259.         * Clear unused portion of window
  260.         @ nMaxRow+1,00 clear to nWindRow,nWindCol
  261.       endif
  262.     endif
  263.  
  264.     if lRepaint .or. nNewRow#nCurRow .or. nNewSCur#nSeekCur
  265.       nSeekCur  = nNewSCur              && New seek cursor length
  266.       nCurRow   = nNewRow               && New cursor position
  267.       if nCurRow>nMaxRow                && Cursor row invalid? (Caused by PgDn)
  268.         nCurRow = nMaxRow               && Put cursor on last displayed row
  269.       endif
  270.  
  271.       * Display cursor
  272.       if nSeekCur>0
  273.         @ nCurRow,00;
  274.           fill to nCurRow,min(nWindCol,nSeekCur-1);
  275.           color &x_ClrPSlct.
  276.       endif
  277.       if nSeekCur<=nWindCol
  278.         @ nCurRow,max(0,nSeekCur);
  279.           fill to nCurRow,nWindCol;
  280.           color &x_ClrPHigh.
  281.       endif
  282.     endif
  283.  
  284.     lRepaint = .F.                      && Reset redisplay flag
  285.  
  286.     nInkey = inkey(0)                   && Get a key-stroke
  287.     do case
  288.       case nInkey=-400                && Shift-Tab
  289.         if isblank(cSeek)
  290.           if lBell
  291.             @ 00,00 say chr(7)
  292.           endif
  293.          else
  294.           if len(cSeek)=nSeekCur
  295.             cSeek = ""
  296.             lSeek = .T.
  297.            else
  298.             goto nRecNo                   && Record at top of window
  299.             skip nCurRow                  && Cursor row
  300.             * Currently seeked string
  301.             cStr  = substr(&cDisplay.,1,nSeekCur)
  302.             * If the last character is a chr(29)
  303.             if substr(cStr,len(cStr),1)=chr(29)
  304.               * Remove the chr(29)
  305.               cStr  = substr(cStr,1,len(cStr)-1)
  306.             endif
  307.             * If there is a chr(29)
  308.             if chr(29)$cStr
  309.               * Remove everything after the last chr(29)
  310.               cSeek = substr(cSeek,1,len(cSeek)-len(cStr)+RAt(chr(29),cStr))
  311.              else
  312.               * Remove everything
  313.               cSeek = ""
  314.             endif
  315.             lSeek = .T.
  316.           endif
  317.         endif
  318.  
  319.       case nInkey=3                   && PageDown
  320.         cSeek     = ""                    && Clear seek string
  321.         nNewSCur  = 0                     && Clear seek cursor
  322.         if nCurRow=nMaxRow                && Is cursor on last line in window?
  323.           goto nRecNo                     && Record at top of window
  324.           skip nWindRow+1                 && Number of records in window
  325.           if eof()
  326.             if lBell
  327.               @ 00,00 say chr(7)          && No more records past bottom of window
  328.             endif
  329.            else
  330.             skip -1                       && Put bottom record at top of window
  331.             nRecNo    = recno()           && New record for top of window
  332.             lRepaint  = .T.               && Redisplay window
  333.           endif
  334.          else                             && Cursor is not on last line in window
  335.           nNewRow = nMaxRow               && Put cursor on last line in window
  336.         endif
  337.  
  338.       case nInkey=5                   && Up Arrow
  339.         cSeek     = ""                    && Clear seek string
  340.         nNewSCur  = 0                     && Clear seek cursor
  341.         if nCurRow>0                      && Is cursor below top of window?
  342.           nNewRow = nCurRow - 1           && Move cursor up
  343.          else                             && Cursor is at top of window
  344.           goto nRecNo                     && Record at top of window
  345.           skip -1
  346.           if bof()
  347.             if lBell
  348.               @ 00,00 say chr(7)            && No previous record
  349.             endif
  350.            else
  351.             nRecNo    = recno()           && New record for top of window
  352.             lRepaint  = .t.               && Redisplay window
  353.           endif
  354.         endif
  355.  
  356.       case nInkey=9                   && Tab
  357.         goto nRecNo                       && Record at top of window
  358.         skip nCurRow                      && Cursor row
  359.         * Characters after currently seeked string
  360.         cStr  = substr(&cDisplay.,nSeekCur+1)
  361.         if (chr(29)$cStr)                 && Tab marker included?
  362.           * Seek everything up to the tab marker
  363.           cStr  = substr(cStr,1,at(chr(29),cStr)-1)
  364.           if .not.seek(cKey+cSeek+cStr)
  365.             cStr  = upper(cStr)
  366.           endif
  367.           if seek(cKey+cSeek+cStr)
  368.             cSeek = cSeek + cStr
  369.             lSeek = .T.
  370.            else
  371.             if lBell
  372.               @ 00,00 say chr(7)
  373.             endif
  374.           endif
  375.          else
  376.           if lBell
  377.             @ 00,00 say chr(7)
  378.           endif
  379.         endif
  380.  
  381.       case nInkey=13 .or. nInkey=23   && Enter .or. Ctrl-W or Ctrl-End
  382.         goto nRecNo                       && Record at top of window
  383.         skip nCurRow                      && Cursor row
  384.         cReturn = &cReturn.               && Return value
  385.         lMore   = .F.                     && Exit main loop
  386.  
  387.       case nInkey=17 .or. nInkey=27   && Ctrl-Q .or. Escape
  388.         cReturn = ""                      && Return value
  389.         lMore   = .F.                     && Exit main loop
  390.  
  391.       case nInkey=18                  && Page Up
  392.         cSeek     = ""                    && Clear seek string
  393.         nNewSCur  = 0                     && Clear seek cursor
  394.         if nCurRow=0                      && Is cursor on top line of window?
  395.           goto nRecNo                     && Record at top of window
  396.           skip -nWindRow                  && Number of records in window
  397.           if bof()
  398.             if lBell
  399.               @ 00,00 say chr(7)            && No more records above top of window
  400.             endif
  401.            else
  402.             nRecNo    = recno()           && New record for top of window
  403.             lRepaint  = .T.               && Redisplay window
  404.           endif
  405.          else                             && Cursor is not on top line of window
  406.           nNewRow = 0                     && Put cursor on top line of window
  407.         endif
  408.  
  409.       case nInkey=24                  && Down Arrow
  410.         cSeek     = ""                    && Clear seek string
  411.         nNewSCur  = 0                     && Clear seek cursor
  412.         if nCurRow<nMaxRow                && Is cursor above bottom of window?
  413.           nNewRow = nCurRow + 1           && Move cursor down
  414.          else                             && Cursor is at bottom of window
  415.           goto nRecNo                     && Record at top of window
  416.           skip nWindRow+1                 && Skip to first record below window
  417.           if eof()
  418.             if lBell
  419.               @ 00,00 say chr(7)            && No records below window
  420.             endif
  421.            else
  422.             goto nRecNo                   && Record at top of window
  423.             skip +1
  424.             nRecNo    = recno()           && New record for top of window
  425.             lRepaint  = .T.               && Redisplay window
  426.           endif
  427.         endif
  428.  
  429.       case nInkey=2 .or. nInkey=30    && End .or. Ctrl-Page Down
  430.         cSeek     = ""                    && Clear seek string
  431.         nNewSCur  = 0                     && Clear seek cursor
  432.         goto bottom                       && Last record in database
  433.         skip -nWindRow                    && Number of records in window
  434.         nNewRow   = nWindRow              && Put cursor on bottom line of window
  435.         nRecNo    = recno()               && New record for top of window
  436.         lRepaint  = .T.                   && Redisplay window
  437.  
  438.       case nInkey=26 .or. nInkey=31   && Home .or. Ctrl-Page Up
  439.         cSeek     = ""                    && Clear seek string
  440.         nNewSCur  = 0                     && Clear seek cursor
  441.         goto top                          && First record in database
  442.         nNewRow   = 0                     && Put cursor on top line of window
  443.         nRecNo    = recno()               && New record for top of window
  444.         lRepaint  = .T.                   && Redisplay window
  445.  
  446.       case nInkey>31 .and. nInkey<127 && Displayable character - Seek it
  447.         cInkey  = chr(nInkey)
  448.         if .not.seek(cKey+cSeek+cInkey)
  449.           cInkey  = upper(cInkey)
  450.         endif
  451.         if seek(cKey+cSeek+cInkey)        && Seek with new character
  452.           cSeek     = cSeek + cInkey      && Add new character to seek string
  453.           lSeek     = .T.
  454.          else
  455.           if lBell
  456.             @ 00,00 say chr(7)              && Seek with new character failed
  457.           endif
  458.         endif
  459.  
  460.       case nInkey=127                 && Back Space
  461.         if len(cSeek)>0                   && Seek string is non-blank
  462.           * Remove last character from seek string
  463.           cSeek = left(cSeek,len(cSeek)-1)
  464.           lSeek = .T.
  465.          else
  466.           if lBell
  467.             @ 00,00 say chr(7)              && Seek string is blank
  468.           endif
  469.         endif
  470.  
  471.       otherwise                       && Unknown key
  472.         b=.t.                             && Breakpoint - used for debugging
  473.         release b
  474.     endcase
  475.   enddo
  476.  
  477.   * Deactivate and release windows
  478.   deactivate window wPickList2
  479.   deactivate window wPickList1
  480.   release windows wPickList1,wPickList2
  481.  
  482.   * Restore database environment
  483.   if .not.isblank(cKey)
  484.     set key to
  485.   endif
  486.  
  487.   *-- Cleanup
  488.   set console       &cConsole.
  489.   set cursor        &cCursor.
  490.   set escape        &cEscape.
  491.   set talk          &cTalk.
  492.  
  493. RETURN cReturn
  494. *-- EoF: Pick1()
  495.  
  496. FUNCTION Pick2
  497. *-------------------------------------------------------------------------------
  498. *-- Programmer..: Malcolm C. Rubel
  499. *-- Date........: 05/18/1992
  500. *-- Notes.......: I stole ... er ... lifted ... this from Data Based Advisor 
  501. *--               (Nov. 1991), and dUFLPed it, as well as removing the FoxPro 
  502. *--               code ...
  503. *--               It's purpose is to create a popup/picklist that will
  504. *--               find the proper location (used with a GET) on the
  505. *--               screen for itself, display the popup and return the 
  506. *--               appropriate value ...
  507. *-- Written for.: dBASE IV, 1.1
  508. *-- Rev. History: 11/01/1991 -- Malcom C. Rubel -- Original Code
  509. *--               05/15/1992 -- Ken Mayer -- several things. First, I dUFLPed
  510. *--               the code, and documented it heavier than the original.
  511. *--                Next, I had to write a function (USED()), as there wasn't
  512. *--               one sitting around that I could see. 
  513. *--                I added the 'cTag' parameter, as well as a few minor changes
  514. *--               to the other functions that come with this routine ... 
  515. *--               05/19/1992 -- Resolved a few minor problems, removed routine
  516. *--               PK_SHOW as being unnecessary (used @nGetRow... GET to 
  517. *--               redisplay field/memvar). Added IsBlank() (copy of EMPTY()) to
  518. *--               handle different field types (original only wanted characters).
  519. *-- Calls.......: ScrRow()             Function in SCREEN.PRG (and here)
  520. *--               ScrCol()             Function in SCREEN.PRG (and here)
  521. *--               Used()               Function in FILES.PRG (and here)
  522. *-- Called by...: Any
  523. *-- Usage.......: Pick2("<cLookFile>","<cTag>","<cSrchFld>","<cRetFld>",;
  524. *--                     <nScrRow>,<nScrCol>)
  525. *-- Example.....: @10,20 get author ;
  526. *--                      valid required pick2("Library","Author",;
  527. *--                      "Last","Last",10,20)
  528. *-- Returns.....: lReturn (found/replaced a value or not ...)
  529. *-- Parameters..: cLookFile = file to lookup in
  530. *--               cTag      = MDX Tag to use (if blank, will use the first
  531. *--                           tag in the MDX file, via the TAG(1) option ...)
  532. *--               cSrchFld  = field(s) to browse -- if blank, function will
  533. *--                           try to use a field of same name as what 
  534. *--                           cursor is on.
  535. *--               cRetFld   = name of field value is to be returned from.
  536. *--               nScrRow   = screen-row (of GET) -- if blank, function will
  537. *--                           determine (use ,, to blank it ... or 0)
  538. *--               nScrCol   = screen-col (of GET) -- if blank, function will
  539. *--                           determine
  540. *-------------------------------------------------------------------------------
  541.  
  542.     parameters cLookFile, cTag, cSrchFld, cRetFld, nScrRow, nScrCol
  543.     private cLookFile,cSrchFld,cRetFld,nScrRow,nScrCol,cVarName,xValReturn,;
  544.             lWasOpen,cCurrBuff,lExact,lReturn,lIsFound,;
  545.             cBarFields,nWinWidth,nGetRow,nGetCol
  546.     
  547.     lReturn = .t.                       && return value must be a logical ...
  548.                                         &&   assume the best ...
  549.     cVarName = varread()                && name of the variable at GET
  550.     xVarValue = &cVarName               && value of the variable at GET
  551.     
  552.     *-- was a 'fieldname' to get value from passed to function?
  553.     if isblank(cRetFld)                 && passed as a null
  554.         cRetFld = cSrchFld               && we'll return contents of same name
  555.                                          &&   as the search field
  556.     endif
  557.     
  558.     nScrRow = ScrRow()                  && get row for picklist
  559.     nScrCol = ScrCol()                  && get column for picklist
  560.     cCurrBuff = alias()                 && current buffer (work area)
  561.     lExact = set("EXACT") = "ON"        && store status of 'EXACT'
  562.     set exact on                        && we want 'exact' matches ...
  563.     
  564.     *-- deal with the 'lookup' file -- if not open, open it, if open,
  565.     *-- select it ...
  566.     if .not. used(cLookFile)            && file not open
  567.         select select()                  && find next open area
  568.         use &cLookFile                   && open file
  569.         lWasOpen = .f.
  570.     else
  571.         select (cLookFile)               && file IS open, move to it ...
  572.         lWasOpen = .t.
  573.     endif
  574.     
  575.     *-- deal with MDX tag for 'lookup' file ...
  576.     if len(trim(cTag)) = 0              && if a null tag was sent,
  577.         set order to Tag(1)              && set the order to first tag
  578.     else
  579.         set order to &cTag               && set it to what user passed.
  580.     endif
  581.     
  582.     *-- screen positions ...
  583.     nGetRow = row()                     && position of 'get' on screen
  584.     nGetCol = iif(isblank(xVarValue),col(),col()-len(&cRetFld))
  585.                                         && get column of 'get' ...
  586.     
  587.     *-- if field is empty, do a lookup, otherwise, look for it in table
  588.     if isblank(xVarValue)               && no data in field
  589.         lIsFound = .f.                   && automatic lookup
  590.     else
  591.         lIsFound = seek(xVarValue)       && look for it in table
  592.     endif
  593.     
  594.     *-- if not found, or field was empty, bring up the lookup ...
  595.     if .not. lIsFound                   && not in table
  596.         go top                           && move pointer to top of 'table'
  597.         *-- make sure it fits on screen
  598.         if cRetFld = cSrchFld            && one browse field
  599.             nWinWidth = len(&cSrchFld) + 3 && width
  600.             cBarFields = cSrchFld         && set the 'browse fields'
  601.         else                             && else multiple ....
  602.             nWinWidth = len(&cSrchFld)+len(&cRetFld)+5
  603.             cBarFields = cSrchFld+", "+cRetFld
  604.         endif
  605.         
  606.         *-- this is how we determine where to start the browse table ...
  607.         nScrCol = iif(nScrCol+nWinWidth>77,77-nWinWidth,nScrCol)
  608.         nScrRow = iif(nScrRow>14,14,nScrRow)
  609.         
  610.         *-- set it up ...
  611.         define window wPick from nScrRow,nScrCol+2 to ;
  612.             nScrRow+10,nScrCol+nWinWidth+2 panel
  613.         activate window wPick
  614.         *on key label ctrl-m keyboard chr(23) && when user presses <enter>,
  615.                                              && force an <enter> ... weird.
  616.         
  617.         *-- activate
  618.         browse fields &cBarFields freeze &cSrchFld noedit noappend;
  619.             nodelete nomenu window wPick
  620.         clear typeahead                  && in case they pressed the <Enter> key
  621.         
  622.         on key label ctrl-m              && reset
  623.         
  624.         release window wPick
  625.         
  626.         if lastkey() # 27                && not the <Esc> key
  627.             store &cRetFld to &cVarName   && put return value into var ...
  628.         else
  629.             lReturn = .F.
  630.         endif
  631.     else
  632.         store &cRetFld to &cVarName
  633.     endif
  634.     
  635.     @nGetRow, nGetCol get &cVarName     && display new value in field/memvar
  636.                                         &&  on screen
  637.     clear gets                          && clear gets from this function
  638.     
  639.     *-- reset work areas, and so on ...
  640.     if .not. lExact
  641.         set exact off
  642.     endif
  643.     if .not. lWasOpen
  644.         use
  645.     endif
  646.     if len(cCurrBuff) # 0
  647.         select (cCurrBuff)
  648.     else
  649.         select select()
  650.     endif
  651.     
  652. RETURN (lReturn)
  653. *-- EoF: Pick2()
  654.  
  655. FUNCTION ScrRow
  656. *-------------------------------------------------------------------------------
  657. *-- Programmer..: Malcolm C. Rubel
  658. *-- Date........: 05/15/1992
  659. *-- Notes.......: Returns the postion of the current 'GET'. If memvar
  660. *--               nScrRow already exists, returns the value of that, unless
  661. *--               it's zero, in which case we return the current position.
  662. *--               This is part of PICK2.
  663. *-- Written for.: dBASE IV, 1.1
  664. *-- Rev. History: 11/01/1991 -- Original Release
  665. *--               05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
  666. *--               0 for the nScrRow memvar.
  667. *-- Calls.......: None
  668. *-- Called by...: Pick2()              Function in PICKLIST.PRG
  669. *-- Usage.......: ScrRow()
  670. *-- Example.....: nScrRow = ScrRow()
  671. *-- Returns.....: Numeric -- position of cursor on screen
  672. *-- Parameters..: None
  673. *-------------------------------------------------------------------------------
  674.  
  675.     if type('nScrRow') # 'N' .or. nScrRow = 0
  676.         RETURN (row())
  677.     else
  678.         RETURN (nScrRow)
  679.     endif
  680. *-- EoF: ScrRow()
  681.     
  682. FUNCTION ScrCol
  683. *-------------------------------------------------------------------------------
  684. *-- Programmer..: Malcolm C. Rubel
  685. *-- Date........: 05/15/1992
  686. *-- Notes.......: Returns the postion of the current 'GET'. If memvar
  687. *--               nScrCol already exists, returns the value of that, unless
  688. *--               it's zero, in which case we return the current position.
  689. *--               This will also return a different value based on whether or
  690. *--               not the field has something in it or not ... This is part of
  691. *--               PICK2.
  692. *-- Written for.: dBASE IV, 1.1
  693. *-- Rev. History: 11/01/1991 -- Original Release
  694. *--               05/15/1992 -- Ken Mayer (71333,1030) to deal with a value of
  695. *--               0 for the nScrCol memvar.
  696. *-- Calls.......: None
  697. *-- Called By...: Pick2()
  698. *-- Usage.......: ScrCol()
  699. *-- Example.....: nScrCol = ScrCol()
  700. *-- Returns.....: Numeric -- position of cursor on screen
  701. *-- Parameters..: None
  702. *-------------------------------------------------------------------------------
  703.  
  704.     if type('nScrCol') # 'N' .or. nScrCol = 0
  705.         if isblank(cRetFld)
  706.             RETURN col() + len(cRetFld)
  707.         else
  708.             RETURN col()
  709.         endif
  710.     else
  711.         RETURN (nScrCol)
  712.     endif
  713.     
  714. *-- EoF: ScrCol()
  715.  
  716. PROCEDURE Pick3
  717. *-------------------------------------------------------------------------------
  718. *-- Programmer..: Martin Leon (HMAN) (A-T)
  719. *-- Date........: 07/12/1991
  720. *-- Notes.......: A "generic" PickList routine ...
  721. *-- Written for.: dBASE IV, 1.1
  722. *-- Rev. History: 11/01/1990 -- Original Release
  723. *--               Published in TechNotes, November, 1990 (DIYPOPUP)
  724. *--               07/12/1991 -- Modified for dHUNG/dUFLP standards, Ken Mayer
  725. *-- Calls.......: None
  726. *-- Called by...: Any
  727. *-- Usage.......: do Pick3 with "<cFields>",<nULRow>,<nULCol>,<nBRRow>,;
  728. *--                <nBRCol>, "<cNormColor>","<cFieldColor>","<cBorder>"
  729. *-- Example.....: Do Pick3 with "First_name+' '+Last_name",5,10,15,60,;
  730. *--                "rg+/gb","gb/r","DOUBLE"
  731. *-- Returns.....: indirectly returns the record pointer of record that was
  732. *--                 highlighted when <Enter> was pressed.
  733. *-- Parameters..: cFields     = fields to be displayed in picklist
  734. *--               nULRow      = Row coordinate of upper left corner
  735. *--               nULCol      = Column coordinate of upper left corner
  736. *--               nBRRow      = Row coordinate of lower right corner
  737. *--               nBRCol      = Column coordinate of lower right corner
  738. *--               cNormColor  = Foreground/Background of normal text
  739. *--               cFieldColor = Foreground/Background of highlighted fields
  740. *--               cBorder     = NONE, SINGLE, DOUBLE (defaults to Single if
  741. *--                               sent as a nul string ("") )
  742. *-------------------------------------------------------------------------------
  743.     parameter cFields, nULRow, nULCol, nBRRow, nBRCol, cNormColor, ;
  744.             cFieldColor, cBorder
  745.  
  746.     cCursor = set("CURSOR")
  747.     cEscape = set("ESCAPE")
  748.     cTalk   = set("TALK")
  749.     set cursor off
  750.     set escape off
  751.     set talk off
  752.     cTypeCheck = type("cFields")+type("nULRow")+type("nULCol")+type("nBRRow")+ ;
  753.         type("nBRCol")+type("cNormColor")+type("cFieldColor")+type("cBorder")
  754.  
  755.     lError = .F.
  756.     do case
  757.         && Check data types
  758.         case cTypeCheck # "CNNNNCCC"
  759.             clear
  760.             @ 7,17 say "Data type mismatch -- check all parameters"
  761.             lError = .T.
  762.         
  763.         && Check for bottom limit with STatUS ON
  764.         case ((nBRRow >21 .and. set("DISPLAY") # "EGA43")    ;
  765.                 .or. (nBRRow >39 .and. set("DISPLAY") = "EGA43")) ;
  766.                 .and. set("STatUS") = "ON"
  767.             clear
  768.             @ 7,15 say "Cannot use this popup on or below STatUS line"
  769.             lError = .T.
  770.         
  771.         && Check for bottom limit with STatUS ofF
  772.         case ((nBRRow >24 .and. set("DISPLAY") # "EGA43")    ;
  773.                 .or. (nBRRow >42 .and. set("DISPLAY") = "EGA43")) ;
  774.                 .and. set("STatUS") = "ofF"
  775.             clear
  776.             @ 7,16 say "Bottom coordinate beyond bottom of screen"
  777.             lError = .T.
  778.         
  779.         && Check left & right coordinates
  780.         case nULCol < 0 .or. nBRCol > 79
  781.             clear
  782.             @ 7,24 say "Invalid Column coordinate"
  783.             lError = .T.
  784.     
  785.         && Check to make sure popup can display at least one record
  786.         case nBRRow - nULRow < 2
  787.             clear
  788.             @ 7,19 say "Popup must be at least 3 lines high"
  789.             lError = .T.
  790.         
  791.     endcase
  792.  
  793.     if lError
  794.         @ 5,5 to 9,70 double
  795.         @ 11, 32 say "Press Any Key"
  796.         nX = 0
  797.         do while nX = 0
  798.             nX = inkey()
  799.         enddo
  800.         set cursor &cCursor
  801.         set escape &cEscape
  802.         set talk &cTalk
  803.         return
  804.     endif
  805.  
  806.     && Save colors of normal and fields to restor when done
  807.     cFieldset = set("ATTRIBUTES")
  808.     cNormSet = left(cFieldset, at(",",cFieldset)-1)
  809.     do while "," $ cFieldset
  810.         cFieldset = substr(cFieldset, at(",",cFieldset)+1)
  811.     enddo
  812.  
  813.     && If they were provided, set to colors passed on from calling program
  814.     if len(cNormColor) # 0
  815.         set color of normal to &cNormColor
  816.     endif
  817.     if len(cFieldColor) # 0
  818.         set color of fields to &cFieldColor
  819.     endif
  820.  
  821.     nPromptW = nBRCol - nULCol - 1
  822.     @ nULRow, nULCol clear to nBRRow, nBRCol 
  823.     @ nULRow, nULCol to nBRRow, nBRCol &cBorder
  824.  
  825.     if eof()
  826.        skip -1
  827.     endif
  828.  
  829.     && Save current record pointer and determine record number of top record
  830.     nTmpRec = recno()
  831.     go top
  832.     nTopRec = recno()
  833.     go nTmpRec
  834.     nMaxRecs = nBRRow - nULRow - 1
  835.     nKey = 0
  836.     lGoBack = .F.
  837.     declare aPrompt[nMaxRecs], aRec[nMaxRecs]
  838.  
  839.     do while .not. lGoBack
  840.         nChcNum = 1
  841.         nTopRow = nULRow + 1
  842.         nLeftCol = nULCol + 1
  843.         nRowOffset = 0
  844.         nLastCurs = 0
  845.  
  846.         && This loop puts text into prompts
  847.         do while nRowOffset + 1 <= nMaxRecs
  848.             if .not. eof()
  849.                 cTemp = &cFields        && Expands cFields into string expression
  850.                 aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
  851.             
  852.                 && If prompt doesn't fill entire box, add spaces
  853.                 if len(aPrompt[nChcNum]) < nPromptW
  854.                     aPrompt[nChcNum] = aPrompt[nChcNum] + ;
  855.                         space(nPromptW - len(aPrompt[nChcNum]))
  856.                 endif
  857.  
  858.                 aRec[nChcNum] = recno()
  859.                 @ nTopRow+nRowOffset , nLeftCol say aPrompt[nChcNum]
  860.             endif
  861.             nRowOffset = nRowOffset + 1
  862.             nChcNum = nChcNum + 1
  863.             skip
  864.         
  865.             && If last record reached, clear rest of box
  866.             if eof()
  867.                 do while nRowOffset + 1 <= nMaxRecs
  868.                     @ nTopRow+nRowOffset, nLeftCol say space(nPromptW)
  869.                     nRowOffset = nRowOffset +1
  870.                 enddo
  871.                 exit
  872.             endif
  873.         enddo
  874.     
  875.         nHighChc = nChcNum - 1
  876.         if nKey # 2 .and. nKey # 3   && if the last key pressed wasn't <end>
  877.             nChcNum = 1               && or <PgDn>
  878.             nRowOffset = 0
  879.         else
  880.             nChcNum = nHighChc
  881.             nRowOffset = nHighChc - 1
  882.         endif
  883.     
  884.         @ nTopRow+nRowOffset , nLeftCol get aPrompt[nChcNum]
  885.         clear gets
  886.     
  887.         && This loops traps the keys
  888.         do while .T.
  889.             nKey = inkey()
  890.             do case
  891.         
  892.                 case nKey = 5   && Up arrow
  893.                 
  894.                     && If first record displayed is first record in database
  895.                     && and it is already highlighted
  896.                     if aRec[1] = nTopRec .and. nChcNum = 1
  897.                         loop
  898.                     endif
  899.                 
  900.                     && If first record is highlighted but is not top record,
  901.                     && shift prompt contents down
  902.                     if aRec[1] # nTopRec .and. nChcNum = 1
  903.                         go aRec[1]
  904.                         nX = nHighChc 
  905.                         do while nX > 1
  906.                             aRec[nX] = aRec[nX - 1]
  907.                             aPrompt[nX] = aPrompt[nX - 1]
  908.                             nX = nX - 1
  909.                         enddo
  910.                     
  911.                         && Get prompt for additional record to be displayed
  912.                         skip -1
  913.                         aRec[1] = recno()
  914.                         cTemp = &cFields
  915.                         aPrompt[1] = substr(cTemp, 1, nPromptW)
  916.                         if len(aPrompt[1]) < nPromptW
  917.                             aPrompt[1] = aPrompt[1] + ;
  918.                                 space(nPromptW - len(aPrompt[1]))
  919.                         endif
  920.                         skip + nMaxRecs
  921.                     
  922.                         && If maximum possible records aren't displayed
  923.                         if nHighChc < nMaxRecs
  924.                             nHighChc = nHighChc + 1
  925.                             skip -1
  926.                             aRec[nHighChc] = recno()
  927.                             cTemp = &cFields
  928.                             aPrompt[nHighChc] = substr(cTemp, 1, nPromptW)
  929.                             if len(aPrompt[nHighChc]) < nPromptW
  930.                                 aPrompt[nHighChc] = aPrompt[nHighChc] + ;
  931.                                 space(nPromptW - len(aPrompt[nHighChc]))
  932.                             endif
  933.                             skip
  934.                         endif
  935.                     
  936.                         && Redisplay prompts with new contents
  937.                         nX = 1
  938.                         do while nX < nHighChc + 1
  939.                             @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
  940.                             nX = nX + 1
  941.                         enddo
  942.                         nChcNum = 2
  943.                     endif
  944.                 
  945.                    nChcNum = iif(nChcNum = 1, nHighChc, nChcNum - 1)
  946.                    nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
  947.                    nLastOne = iif(nChcNum = nHighChc, 1, nChcNum+1)
  948.                    nThisOne = nChcNum
  949.  
  950.                    @ nTopRow+iif(nChcNum = nHighChc, 0, nRowOffset+1) , ;
  951.                       nLeftCol say aPrompt[nLastOne]
  952.                    @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
  953.                    clear gets
  954.  
  955.                 case nKey = 24   && Dn arrow
  956.                 
  957.                     && If last prompt is highlighted and it is last record
  958.                     if eof() .and. nChcNum = nHighChc
  959.                         loop
  960.                     endif
  961.                 
  962.                     && If not at last record and bottom prompt is highlighted,
  963.                     && shift prompt contents up
  964.                     if .not. eof() .and. nChcNum = nHighChc
  965.                         nX = 1
  966.                         do while nX < nMaxRecs
  967.                             aRec[nX] = aRec[nX + 1]
  968.                             aPrompt[nX] = aPrompt[nX + 1]
  969.                             nX = nX + 1
  970.                         enddo
  971.                     
  972.                         && Get prompt for additional record to be displayed
  973.                         aRec[nMaxRecs] = recno()
  974.                         cTemp = &cFields
  975.                         aPrompt[nMaxRecs] = substr(cTemp, 1, nPromptW)
  976.                         if len(aPrompt[nMaxRecs]) < nPromptW
  977.                             aPrompt[nMaxRecs] = aPrompt[nMaxRecs] + ;
  978.                                 space(nPromptW - len(aPrompt[nMaxRecs]))
  979.                         endif
  980.                         skip
  981.                     
  982.                         && Redisplay prompts with new contents
  983.                         nX = nMaxRecs
  984.                         do while nX > 0
  985.                             @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
  986.                             nX = nX - 1
  987.                         enddo
  988.                         nChcNum = nMaxRecs - 1
  989.                     endif
  990.                 
  991.                    nChcNum = iif(nChcNum < nHighChc, nChcNum + 1, 1)
  992.                    nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
  993.                    nLastOne = iif(nChcNum = 1, nHighChc, nChcNum-1)
  994.                    nThisOne = nChcNum
  995.  
  996.                    @ nTopRow+iif(nChcNum = 1, nHighChc-1, nRowOffset-1) , ;
  997.                       nLeftCol say aPrompt[nLastOne]
  998.                    @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
  999.                    clear gets
  1000.  
  1001.                 case nKey = 13   && Enter key
  1002.                     && Move record pointer and go back to calling program
  1003.                     go aRec[nChcNum]
  1004.                     lGoBack = .T.
  1005.                     exit
  1006.  
  1007.                 case nKey = 3    && PgDn key
  1008.                 
  1009.                     && If last record in .DBF is displayed but not highlighted,
  1010.                     && move highlight to bottom and wait for next key 
  1011.                     if eof() .and. nChcNum # nHighChc
  1012.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1013.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1014.                         clear gets
  1015.                         nChcNum = nHighChc
  1016.                   nRowOffset = nChcNum - 1
  1017.                         loop
  1018.                     endif
  1019.                 
  1020.                     && If highlight is not on last record that is displayed,
  1021.                     && move highlight to it and wait for next key
  1022.                     if nChcNum # nHighChc
  1023.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1024.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1025.                         clear gets
  1026.                         nChcNum = nHighChc
  1027.                   nRowOffset = nChcNum - 1
  1028.                   loop
  1029.                     endif
  1030.                 
  1031.                     && Highlight is at bottom record displayed but not at eof
  1032.                     && Move record pointer down to next "page" of records and
  1033.                     && return to main loop
  1034.                     if .not. eof()
  1035.                         go aRec[1]
  1036.                         skip + nMaxRecs
  1037.                         lGoBack = .F.
  1038.                         exit
  1039.                     endif
  1040.                 
  1041.                     && If none of the above is true, wait for another key
  1042.                     loop
  1043.  
  1044.                 case nKey = 18    && PgUp key
  1045.                 
  1046.                     && If top record displayed is top of .DBF but it is
  1047.                     && not highlighted, move highlight to it and wait for next key
  1048.                     if aRec[1] = nTopRec .and. nChcNum # 1
  1049.                    @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1050.                         @ nTopRow, nLeftCol get aPrompt[1]
  1051.                         clear gets
  1052.                         nChcNum = 1
  1053.                   nRowOffset = 0
  1054.                   loop
  1055.                     endif
  1056.                 
  1057.                     && If highlight is not on top record displayed, move 
  1058.                     && highlight to it and wait for next key
  1059.                     if nChcNum # 1
  1060.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1061.                         @ nTopRow, nLeftCol get aPrompt[1]
  1062.                         clear gets
  1063.                         nChcNum = 1
  1064.                   nRowOffset = 0
  1065.                         loop
  1066.                     endif
  1067.                 
  1068.                     && Highlight is at top record displayed but not at top of DBF.
  1069.                     && Move record pointer up one "page" worth of records and 
  1070.                     && return to main loop to display new prompts
  1071.                     if aRec[1] # nTopRec
  1072.                         go aRec[1]
  1073.                         skip - nMaxRecs
  1074.                         lGoBack = .F.
  1075.                         exit
  1076.                     endif
  1077.                 
  1078.                     && If none of the above is true, wait for next key
  1079.                     loop
  1080.                 
  1081.                 case nKey = 27   && Esc key
  1082.                     && Move record pointer to where it was before starting this
  1083.                     && routine and return to calling program
  1084.                     lAbandon = .T.
  1085.                     lGoBack = .T.
  1086.                     go nTmpRec
  1087.                     exit
  1088.  
  1089.                 case nKey = 26    && Home key
  1090.                 
  1091.                     && If already at top of DBF, wait for next key
  1092.                     if aRec[1] = nTopRec
  1093.                     loop
  1094.                  else && go top and return to main loop to display new prompts
  1095.                         go top
  1096.                         lGoBack = .F.
  1097.                         exit
  1098.                     endif
  1099.  
  1100.                 case nKey = 2    && End key
  1101.             
  1102.                     && If last record in DBF is displayed but not highlighted,
  1103.                     && move highlight to it and wait for next key
  1104.                     if eof() .and. nChcNum # nHighChc
  1105.                   @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
  1106.                         @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
  1107.                         clear gets
  1108.                         nChcNum = nHighChc
  1109.                   nRowOffset = nChcNum - 1
  1110.                        loop
  1111.                     endif
  1112.                 
  1113.                     && If last record is not displayed, go to it and 
  1114.                     &&    return to main loop
  1115.                     if .not. eof()
  1116.                         go BOTtoM
  1117.                         skip - (nMaxRecs - 1)
  1118.                         lGoBack = .F.
  1119.                         exit
  1120.                     endif
  1121.                 
  1122.                     && If none of the above is true, go back and wait for next key
  1123.                     loop
  1124.  
  1125.                 case nKey = 28  && F1 key
  1126.                     && This is just sample code for the F1 key
  1127.                     define window TempWin from 5,4 to 14,75
  1128.                     activate window TempWin
  1129.                     @ 1,3 say "Use cursor keys to choose. Press <Enter> to move record pointer"
  1130.                     @ 2,5 say "Use <PgUp>, <PgDn>, <Home>, and <End> to see other records"
  1131.                     @ 3,26 say "Use <Esc> to abandon"
  1132.                     @ 5,23 say "Press Any Key to Continue"
  1133.                     nX = 0
  1134.                     do while nX = 0
  1135.                         nX = inkey()
  1136.                     enddo
  1137.                     deactivate window TempWin
  1138.             
  1139.                 case nKey = -1  && F2 key
  1140.                     && This is just sample code for the F2 key
  1141.                     save screen to sScreen
  1142.                     nX = recno()
  1143.                     go aRec[nChcNum]
  1144.                     set cursor ON
  1145.                 edit nomenu noappend nodelete next 1
  1146.                     * READ is better if you already have a FORMat set.
  1147.                set cursor off
  1148.                go aRec[nChcNum]
  1149.                cTemp = &cFields  && Expands cFields into string expression
  1150.                     aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
  1151.                     if len(aPrompt[nChcNum]) < nPromptW
  1152.                         aPrompt[nChcNum] = aPrompt[nChcNum] + ;
  1153.                         space(nPromptW - len(aPrompt[nChcNum]))
  1154.                     endif
  1155.                restore screen from sScreen
  1156.                     @ nTopRow+nRowOffset, nLeftCol get aPrompt[nChcNum]
  1157.                clear gets
  1158.                if nX <= reccount()
  1159.                         go nX
  1160.                     else
  1161.                         go bott
  1162.                         skip
  1163.                     endif
  1164.             endcase
  1165.         enddo
  1166.     enddo
  1167.  
  1168.     && Put colors back to what they were and set CURSOR, escape, and TALK back
  1169.     set color of normal to &cNormSet
  1170.     set color of fields to &cFieldset
  1171.     set cursor &cCursor
  1172.     set escape &cEscape
  1173.     set talk &cTalk
  1174.     
  1175. RETURN
  1176. *-- EOP: Pick3
  1177.  
  1178. FUNCTION Pick4
  1179. *-------------------------------------------------------------------------------
  1180. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1181. *-- Date........: 02/16/1993
  1182. *-- Notes.......: This is a generic picklist routine.
  1183. *-- Written for.: dBASE IV, 1.1
  1184. *-- Rev. History: 10/01/1992 -- Original version
  1185. *--               11/03/1992 -- Modified to dUFLP it (and use RECOLOR to
  1186. *--                ensure that colors are returned properly) -- Ken Mayer
  1187. *--               02/16/1993 -- Minor changes to deal with small data files
  1188. *--                by Keith.
  1189. *-- Calls.......: ReColor              PROCEDURE in PROC.PRG
  1190. *-- Called by...: Any
  1191. *-- Usage.......: Pick4(nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,;
  1192. *--                     nRetType,cColors
  1193. *-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
  1194. *--                     "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
  1195. *-- Returns.....: number of characters from prompt()
  1196. *-- Parameters..: nRow        = Upper Left Corner Row
  1197. *--               nCol        = Upper Left Corner Column
  1198. *--               cTitle      = Title to display at top of list
  1199. *--               cFileSpecs  = "FILENAME,ORDER,SET_KEY_TO"
  1200. *--               cListWhat   = What should display as prompt
  1201. *--               nRetChar    = Number of characters of prompt to return
  1202. *--               nReturnType = 0 = KEYB(), 1 = Normal Return
  1203. *--               cColors     = Background/Unselected Items,;
  1204. *--                             Selected letters/border, selected bar
  1205. *--                             example: rg+/gb,w+/b,w+/n
  1206. *--                              rg+/gb = unselected items (and background)
  1207. *--                              w+/b   = selected letter(s)
  1208. *--                              w+/n   = currently highlighted bar
  1209. *-------------------------------------------------------------------------------
  1210.  
  1211.    para nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,nReturnType,cColors
  1212.  
  1213.    private nLastBar,cTalk,cStatus,cNColor,cBColor,cHColor,nPick,;
  1214.            cWindow,cCursor,cAlias,sPick,cAttrib,nLastBar, nDone,;
  1215.            nX,nP,nO,aBar,lRefresh,nLCol,nRCol,nPKey,cExact,  ;
  1216.            cSeek,nOldRow,nOldWidth,xRetVal,cSetKey
  1217.  
  1218.     *-- basic environmental stuff
  1219.    cTalk = set("talk")
  1220.    set talk off
  1221.     *-- set default colors
  1222.    cNColor = "w/n"
  1223.    cBColor = "w+/n"
  1224.    cHColor = "n/w"
  1225.     *-- if user passed this parameter
  1226.    if len(cColors) > 0
  1227.       nX = at(",",cColors)
  1228.       cNColor = left(cColors,nX-1)
  1229.       cColors = substr(cColors,nX+1)
  1230.       if len(cColors) > 0
  1231.          nX = at(",",cColors)
  1232.          cBColor = iif(nX > 0,left(cColors,nX-1),cColors)
  1233.          cColors = iif(nX > 0,substr(cColors,nX+1),"")
  1234.          if len(cColors) > 0
  1235.             cHColor = cColors
  1236.         endif
  1237.       endif
  1238.    endif
  1239.     
  1240.     *-- save current screen colors and screen, modify environment some more
  1241.    cAttrib = set("attr")
  1242.    set color to &cHColor,&cNColor
  1243.    save screen to sPick
  1244.    cStatus = set("status")
  1245.    set status off
  1246.    restore screen from sPick
  1247.    cCursor = set("cursor")
  1248.    set cursor off
  1249.    cWindow = window()
  1250.    activate screen
  1251.    cExact = set("exact")
  1252.    cSeek = ""
  1253.    set exact off
  1254.    set near off
  1255.  
  1256.     *-- display
  1257.    @ 9,32 clear to 9,47
  1258.    @ 9,32 fill to 11,49 color w/n
  1259.    @ 8,31 to 10,48 color &cBColor
  1260.    @ 9,32 say " Please wait... " color &cNColor
  1261.     
  1262.     *-- create the picklist
  1263.    declare aBar[10]
  1264.    cOrder = ""
  1265.    cSetKey = ""
  1266.    cFile = cFileSpecs
  1267.    nX = at(",",cFileSpecs)
  1268.    if nX > 0
  1269.       cFile= left(cFileSpecs,nX-1)
  1270.       cFileSpecs = substr(cFileSpecs,nX+1)
  1271.       if len(cFileSpecs) > 0
  1272.          nX = at(",",cFileSpecs)
  1273.          cOrder = iif(nX>0,left(cFileSpecs,nX-1),cFileSpecs)
  1274.          cFileSpecs = iif(nX>0,substr(cFileSpecs,nX+1),"")
  1275.          if len(cFileSpecs) > 0
  1276.             cSetKey = cFileSpecs
  1277.          endif
  1278.       endif
  1279.    endif
  1280.    cAlias = alias()
  1281.    nLastBar = 9
  1282.    nP = 1 
  1283.    nO = 1
  1284.    nDone = 0
  1285.    lRefresh = .t.
  1286.    lSameFile = (cAlias = upper(cFile))
  1287.    use &cFile. again in select() alias picker
  1288.    if len(tag(1)) > 0
  1289.       set order to tag(1)
  1290.    endif
  1291.    set deleted on
  1292.    if len(trim(cOrder)) > 0
  1293.       set order to &cOrder.
  1294.    endif
  1295.    if len(trim(cSetKey)) > 0
  1296.       if at(",",cSetKey) > 0
  1297.          cSetKey = "range "+ cSetKey
  1298.       endif
  1299.       set Key to &cSetKey.
  1300.    endif
  1301.    go top
  1302.    nDone = iif(reccount() < 1,2,0)
  1303.    if nRow > 14
  1304.       nRow = 14
  1305.    endif
  1306.    nOldWidth = -1
  1307.    nOldRow = -1
  1308.    nLastBar = 9
  1309.    do while nDone = 0
  1310.       if lRefresh .and. .not. eof("picker")
  1311.          nWidth = 0
  1312.          nX = 0
  1313.          do while nX < 8 .and. .not. eof("picker")
  1314.             nX = nX + 1
  1315.             aBar[nX] = &cListWhat
  1316.             if len(aBar[nX]) > nWidth
  1317.                nWidth = len(aBar[nX])
  1318.             endif
  1319.             skip 1
  1320.          enddo
  1321.          nLastBar = nX
  1322.          nLCol = nCol
  1323.          nRCol = nLCol + nWidth + 4
  1324.          do while (nRCol > 77) .and. (nLCol > 0)
  1325.             if nLCol > 1
  1326.                nRCol = nRCol - 1
  1327.                nLCol = nLCol - 1
  1328.             else
  1329.                nRCol = 77
  1330.             endif
  1331.          enddo
  1332.          if (nWidth <> nOldWidth) .or. (nLastBar <> nOldRow)
  1333.             restore screen from sPick
  1334.             @ nRow+1, nLCol+1 fill  to ;
  1335.               nRow+nLastBar+2,nRCol+2 color w/n
  1336.             @ nRow  , nLCol         to ;
  1337.               nRow+nLastBar+1,nRCol   color &cBColor
  1338.             @ nRow  , nLCol+1 say '['   color &cBColor
  1339.             @ nRow  , nLCol+2 say cTitle color &cNColor
  1340.             @ nRow  , nLCol+2+len(cTitle) say ']' color &cBColor
  1341.          endif
  1342.          @ nRow+1, nLCol+1 clear to ;
  1343.            nRow+nLastBar  ,nRCol-1
  1344.          @ nRow+1, nLCol+1 fill  to ;
  1345.            nRow+nLastBar  ,nRCol-1 color &cBColor
  1346.          nOldRow = nLastBar
  1347.          nOldWidth = nWidth
  1348.          nX = 1
  1349.          do while nX <= nLastBar
  1350.             @ nX+nRow,nLCol+2 say " "+aBar[nX] color &cNColor
  1351.             nX = nX + 1
  1352.          enddo
  1353.       endif
  1354.       if nP > nLastBar
  1355.          nP = nLastBar
  1356.       endif
  1357.       if nO <= nLastBar
  1358.          @ nRow+nO, nLCol+2 fill to nRow+nO,nRCol-2 color &cNColor
  1359.       endif
  1360.       @ nRow+nP, nLCol+2 fill to nRow+nP,nRCol-2 color &cHColor
  1361.       nX = at(upper(cSeek),upper(aBar[nP]))
  1362.       if nX > 0
  1363.          @ nRow+nP,nLCol+2+nX fill to nRow+nP,nLCol+1+nX+len(cSeek) ;
  1364.            color &cBColor
  1365.       endif
  1366.       nO = nP
  1367.  
  1368.       *-- start processing key strokes ...
  1369.       nPKey = inkey(0)
  1370.       do case
  1371.          case nPKey = 5                                 && up
  1372.             nP = nP - 1
  1373.             if nP < 1
  1374.                nPKey = 18
  1375.                nP = nLastBar
  1376.             endif
  1377.             cSeek = ""
  1378.          case nPKey = 24                                && down
  1379.             nP = nP + 1
  1380.             if nP > nLastBar
  1381.                if .not. eof("picker")
  1382.                   nPKey = 3
  1383.                   nP = 1
  1384.                else
  1385.                   nPKey = 0
  1386.                   nP = nP - 1
  1387.                endif
  1388.             endif
  1389.             cSeek = ""
  1390.       endcase
  1391.       lRefresh = .t.
  1392.       do case
  1393.       case nPKey = 18                                && pgup, up
  1394.          skip - 16
  1395.          if bof()
  1396.             go top
  1397.          endif
  1398.          cSeek = ""
  1399.       case nPKey = 26                                && home
  1400.          go top
  1401.          nP = 1
  1402.          cSeek = ""
  1403.       case nPKey = 2                                 && end
  1404.          go bottom
  1405.          skip - 7
  1406.          if bof()
  1407.             go top
  1408.          else
  1409.             nP = nLastBar
  1410.          endif
  1411.          cSeek = ""
  1412.       case nPKey = 27                                && esc
  1413.          nDone = 1
  1414.       case (nPKey = 13) .or. (nPkey = 23)            && c/r
  1415.          nPick = aBar[nP]
  1416.          nDone = 1
  1417.       case ((nPKey >= asc(" ")) .and. (nPKey <= asc("z"))) .or. (nPKey = 127)
  1418.          if nPKey = 127
  1419.             cSeek = left(cSeek,len(cSeek)-1)
  1420.          else
  1421.             cSeek = cSeek + chr(nPKey)
  1422.          endif
  1423.          if len(trim(tag())) > 0
  1424.             seek(cSeek)
  1425.             if .not. found()
  1426.                seek(upper(cSeek))
  1427.             endif
  1428.          endif
  1429.          if .not. found()
  1430.              cSeek = left(cSeek,len(cSeek)-1)
  1431.              ?? chr(7)
  1432.          endif
  1433.          if len(trim(cSeek)) = 0
  1434.             go top
  1435.          endif
  1436.          lRefresh = .t.
  1437.          nPKey = 3
  1438.       otherwise
  1439.          if (nPKey <> 3)
  1440.             lRefresh = .f.
  1441.          endif
  1442.       endcase
  1443.    enddo
  1444.  
  1445.     *-- return something, unless <Esc> was pressed
  1446.    if nPKey <> 27
  1447.       if nReturnType = 0
  1448.          keyboard chr(26)+chr(25)+left(nPick,nRetChar)+chr(13)
  1449.       endif
  1450.       xRetVal = iif(nReturnType=0,.t.,iif(nPKey=27,"",left(nPick,nRetChar)))
  1451.    else
  1452.       xRetVal = .f.
  1453.    endif
  1454.  
  1455.     *-- cleanup
  1456.    select picker
  1457.    use
  1458.    if len(trim(cAlias)) > 0
  1459.       select (cAlias)
  1460.    endif
  1461.    if len(trim(cWindow)) > 0
  1462.       activate window &cWindow
  1463.    endif
  1464.     do recolor with cAttrib   
  1465.    set status &cStatus
  1466.    set talk &cTalk
  1467.    set cursor &cCursor
  1468.    set exact &cExact
  1469.    restore screen from sPick
  1470.  
  1471. RETURN xRetVal
  1472. *-- EoF: Pick4()
  1473.  
  1474. FUNCTION PopList
  1475. *-------------------------------------------------------------------------------
  1476. *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
  1477. *-- Date........: 11/30/1992
  1478. *-- Notes.......: Display a popup constructed from up to 9 options. The routine
  1479. *--               then keyboards the first characters of the selected option 
  1480. *--               up to the length of the field/memvar) directly into 
  1481. *--               field/memvar. Used in place of the picture function "@M" 
  1482. *--               built-in to dBASE IV. This should be used only in a VALID 
  1483. *--               REQUIRED clause, not a WHEN clause.
  1484. *-- Written for.: dBASE IV, 1.5
  1485. *-- Rev. History: 11/30/1992 -- Original Release
  1486. *-- Calls.......: None
  1487. *-- Called by...: Any
  1488. *-- Usage.......: PopList(<cP1>,<cP2>,<cP3>,<cP4>,<cP5>,...<cP9>)
  1489. *-- Example.....: @6,37 get m->cHanded picture "!" valid required;
  1490. *--                     poplist("Right-handed","Left-handed")
  1491. *-- Returns.....: Logical: .T. when variable being read matches options,
  1492. *--                        .F. otherwise
  1493. *-- Parameters..: cP1 = First parameter for list
  1494. *--               ...
  1495. *--               cP9 = Last this is max routine will allow ... number varies, 
  1496. *--                     should always have at least two, otherwise, what's the 
  1497. *--                     point?
  1498. *-------------------------------------------------------------------------------
  1499.     parameters cP1,cP2,cP3,cP4,cP5,cP6,cP7,cP8,cP9
  1500.     private nPopLen,nPop,nPopRow,nPopCol,nPopECol,nPopBRow,nPop,cPopPar,;
  1501.             cPopRead,cPopRet,nPopInLen,cPopInput
  1502.     
  1503.     nPopLen = 0
  1504.     nPop    = 0
  1505.     cPopRead = VarRead()        && get memvar/field being read
  1506.     cPopInput = &cPopRead       && store again?
  1507.     nPopInLen = len(cPopInput)  && get length
  1508.     declare cPopBar[pcount()]   && define array
  1509.     do while nPop < pcount()
  1510.         nPop = nPop + 1
  1511.         cPopPar = "cP"+ltrim(str(nPop))
  1512.         cPopBar[nPop] = &cPopPar
  1513.         nPopLen = max(nPopLen,len(cPopBar[nPop]))
  1514.         if (cPopInput=left(cPopBar[nPop],nPopInLen)) .and. ;
  1515.             (left(cPopBar[nPop],nPopInLen)=cPopInput)
  1516.             RETURN .T.
  1517.         endif
  1518.     enddo
  1519.     
  1520.     *-- set coordinates of popup (checking for edge of screen ...)
  1521.     nPopRow = row()
  1522.     nPopCol = col() + nPopInLen
  1523.     if nPopRow + pCount() + 1 > 24
  1524.         nPopRow = 23-pCount()
  1525.     endif
  1526.     nPopBRow = nPopRow + pcount() + 1
  1527.     if nPopCol + nPopLen > 79
  1528.         nPopCol = 75-nPopLen
  1529.     endif
  1530.     nPopECol = nPopCol + nPopLen + 1
  1531.     
  1532.     *-- define popup
  1533.     save screen to sPopList
  1534.     define popup PopList from nPopRow,nPopCol to nPopBRow,nPopECol
  1535.     nPop = 0
  1536.     do while nPop < pcount()
  1537.         nPop = nPop + 1
  1538.         define bar nPop of PopList prompt cPopBar[nPop]
  1539.     enddo
  1540.     on selection popup PopList deactivate popup
  1541.     activate popup PopList
  1542.     
  1543.     *-- now we have it, let's deal with output
  1544.     cPopRet = left(prompt(),nPopInLen)
  1545.     
  1546.     *-- cleanup screen and memory
  1547.     release popup PopList
  1548.     restore screen from sPopList
  1549.     release screen sPopList
  1550.     
  1551.     *-- replace data in field for user
  1552.     *-- space is necessary for the valid required error about
  1553.     *--        "Editing condition not satisified ..."
  1554.     *-- chr(26) and chr(25) move cursor to "home" and delete contents
  1555.     *-- of field, so new data can be keyboarded in
  1556.     keyboard " "+chr(26)+chr(25)+cPopRet + iif(set("CONFIRM")="ON",chr(13),"")
  1557.     
  1558. RETURN .F.
  1559. *-- EoF: PopList()
  1560.  
  1561. PROCEDURE Diacrit
  1562. *-------------------------------------------------------------------------------
  1563. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1564. *-- Date........: 01/27/1993
  1565. *-- Notes.......: Used to insert those letters with diacritical marks into
  1566. *--               your input screens. This routine brings up a picklist with
  1567. *--               all the standard diacrit characters built into the ASCII
  1568. *--               character set. 
  1569. *--               NOTE: To use this routine properly, two things must be
  1570. *--                done first:
  1571. *--                PUBLIC n_RowPop, n_ColPop
  1572. *--                a Call to LocPop() should be made with a WHEN clause in
  1573. *--                the "get". See example below.
  1574. *-- Written for.: dBASE IV, 1.5
  1575. *-- Rev. History: 12/28/1992 -- Original Release
  1576. *--               01/27/1993 -- Modified (KJM) to cope with data entry WINDOWS
  1577. *--                which includes restoring the active window when done.
  1578. *-- Calls.......: LocPop()             Indirectly. FUNCTION in PICKLIST.PRG
  1579. *-- Called by...: Any (routine with a GET)
  1580. *-- Usage.......: DO Diacrit 
  1581. *-- Example.....: public n_RowPop, n_ColPop         && vital
  1582. *--               @5,10 get cVar when LocPop(5,10)  && vital
  1583. *--               ON KEY LABEL ALT-K DO DIACRIT 
  1584. *--               read
  1585. *--               on key label alt-k  && release definition
  1586. *-- Returns.....: Keyboards character into current "GET"
  1587. *-- Parameters..: None
  1588. *-------------------------------------------------------------------------------
  1589.     
  1590.     private nRow, nCol, nRow2, nCol2, cReturn
  1591.     on key label alt-k ?? chr(7)  && beep if user tries to call again ...
  1592.     
  1593.     *-- first things first, define where it's to display
  1594.     cWindow = window() && save current window if there is one
  1595.     activate screen
  1596.     nRow = n_RowPop   && get values from public memvars
  1597.     nCol = n_ColPop
  1598.     
  1599.     *-- bottom right corner of popup ...
  1600.     nCol2 = nCol + 5
  1601.     nRow2 = nRow + 10
  1602.     
  1603.     *-- define the popup
  1604.     define popup pDiacrit from nRow,nCol to nRow2,nCol2 
  1605.     define bar  1 of pDiacrit prompt " "+chr(142)+" "  && Ä
  1606.     define bar  2 of pDiacrit prompt " "+chr(143)+" "  && Å
  1607.     define bar  3 of pDiacrit prompt " "+chr(146)+" "  && Æ
  1608.     define bar  4 of pDiacrit prompt " "+chr(131)+" "  && â
  1609.     define bar  5 of pDiacrit prompt " "+chr(132)+" "  && ä
  1610.     define bar  6 of pDiacrit prompt " "+chr(133)+" "  && à
  1611.     define bar  7 of pDiacrit prompt " "+chr(134)+" "  && å
  1612.     define bar  8 of pDiacrit prompt " "+chr(160)+" "  && á
  1613.     define bar  9 of pDiacrit prompt " "+chr(145)+" "  && æ
  1614.     define bar 10 of pDiacrit prompt " "+chr(144)+" "  && É
  1615.     define bar 11 of pDiacrit prompt " "+chr(136)+" "  && ê
  1616.     define bar 12 of pDiacrit prompt " "+chr(137)+" "  && ë
  1617.     define bar 13 of pDiacrit prompt " "+chr(138)+" "  && è
  1618.     define bar 14 of pDiacrit prompt " "+chr(130)+" "  && é
  1619.     define bar 15 of pDiacrit prompt " "+chr(139)+" "  && ï
  1620.     define bar 16 of pDiacrit prompt " "+chr(140)+" "  && î
  1621.     define bar 17 of pDiacrit prompt " "+chr(141)+" "  && ì
  1622.     define bar 18 of pDiacrit prompt " "+chr(161)+" "  && í
  1623.     define bar 19 of pDiacrit prompt " "+chr(147)+" "  && ô
  1624.     define bar 20 of pDiacrit prompt " "+chr(148)+" "  && ö
  1625.     define bar 21 of pDiacrit prompt " "+chr(149)+" "  && ò
  1626.     define bar 22 of pDiacrit prompt " "+chr(162)+" "  && ó
  1627.     define bar 23 of pDiacrit prompt " "+chr(153)+" "  && Ö
  1628.     define bar 24 of pDiacrit prompt " "+chr(150)+" "  && û
  1629.     define bar 25 of pDiacrit prompt " "+chr(129)+" "  && ü
  1630.     define bar 26 of pDiacrit prompt " "+chr(151)+" "  && ù
  1631.     define bar 27 of pDiacrit prompt " "+chr(163)+" "  && ú
  1632.     define bar 28 of pDiacrit prompt " "+chr(154)+" "  && Ü
  1633.     define bar 29 of pDiacrit prompt " "+chr(152)+" "  && ÿ
  1634.     define bar 30 of pDiacrit prompt " "+chr(128)+" "  && Ç
  1635.     define bar 31 of pDiacrit prompt " "+chr(165)+" "  && Ñ
  1636.     define bar 32 of pDiacrit prompt " "+chr(164)+" "  && ñ
  1637.     
  1638.     *-- whatta we do with it?
  1639.     on selection popup pDiacrit deactivate popup
  1640.     activate popup pDiacrit
  1641.     cPrompt = prompt()
  1642.     
  1643.     *--            Esc                ->                  <-
  1644.     if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
  1645.         cReturn = ""
  1646.     else
  1647.         cReturn = substr(cPrompt,2,1)  && get the actual character ...
  1648.     endif
  1649.     
  1650.     *-- remove from memory
  1651.     release popup pDiacrit
  1652.     *-- reactivate window if there was one ...
  1653.     if .not. isblank(cWindow)
  1654.         activate window &cWindow
  1655.     endif
  1656.     *-- put into user's "Get"
  1657.     keyboard cReturn
  1658.     *-- reset ON KEY definition
  1659.     on key label alt-k do diacrit
  1660.     
  1661. RETURN
  1662. *-- EoP: Diacrit
  1663.  
  1664. FUNCTION LocPop
  1665. *-------------------------------------------------------------------------------
  1666. *-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 71542,2712)
  1667. *-- Date........: 01/28/1993
  1668. *-- Notes.......: Created for diacritical routine above, to determine position
  1669. *--               of current "Get", and then decide whether to place upper
  1670. *--               left coordinates (in public memvars: n_RowPop, n_ColPop)
  1671. *--               of a popup. 
  1672. *-- Written for.: dBASE IV, 1.5
  1673. *-- Rev. History: 12/25/1992 -- Original
  1674. *--               12/28/1992 -- Modified to deal with positioning if get is
  1675. *--                to far to the right on the screen, and so on (Ken Mayer).
  1676. *--               01/28/1993 -- Modified to handle windows on screen, giving
  1677. *--                an absolute address. Requires user to provide coordinates
  1678. *--                for upper left corner of window.
  1679. *-- Calls.......: VidRow()               Function in SCREEN.PRG
  1680. *--               VidCol()               Function in SCREEN.PRG
  1681. *-- Called by...: Diacrit   (Indirectly) Procedure in PICKLIST.PRG
  1682. *-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWBorder>])
  1683. *-- Example.....: @5,10 get cVar when LocPop(5,10)
  1684. *-- Returns.....: logical true
  1685. *-- Parameters..: nWidth   = width of popup
  1686. *--               nLength  = length of popup (how many bars should display on
  1687. *--                           screen -- used to determine if displaying above
  1688. *--                           or below ROW() of GET)
  1689. *--               nWBorder = OPTIONAL -- if there is no border we have to back
  1690. *--                            up one, so put a '0' in here if there is no
  1691. *--                            border, otherwise, ignore this parameter.
  1692. *-------------------------------------------------------------------------------
  1693.     
  1694.     parameters nWidth,nLength, nWBorder
  1695.     private cVar, nRow, nCol
  1696.     
  1697.     *-- get current "GET"
  1698.     cVar = varread()
  1699.     
  1700.     *-- put current position into column/row ... since cursor was just placed
  1701.     *-- into field (assuming called from WHEN clause), we are always on the
  1702.     *-- first character in the GET ...
  1703.     nRow = VidRow()
  1704.     nCol = VidCol() 
  1705.     
  1706.     if type("NWBORDER") # "L" .and. nWBorder = 0
  1707.         nRow = nRow - 1
  1708.         nCol = nCol - 1
  1709.     endif
  1710.     
  1711.     *-- add it all up, see if popup coordinates are off the screen
  1712.     *-- if so, we need to display the popup UNDER the GET
  1713.     if nCol + (len(&cVar)+nWidth+1) > 79 
  1714.         nRow = nRow + 1                 
  1715.         nCol = 79 - nWidth              && put it right up against edge of screen
  1716.     else                               && otherwise, set column position
  1717.         nCol = nCol + len(&cVar) + 1    && add length of memvar/get
  1718.     endif
  1719.     
  1720.     *-- now to see if we're going to go off the bottom of the screen
  1721.     *-- and deal with _that_ -- displaying popup ABOVE the GET.
  1722.     nDisp = val(right(set("DISPLAY"),2))  && (EGAxx ...)
  1723.     if nRow + nLength +2 => nDisp - 1  && check for bottom of screen
  1724.         nRow = nRow - nLength - 2 
  1725.     endif
  1726.     
  1727.     if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
  1728.         public n_RowPop,n_ColPop
  1729.     endif
  1730.     n_RowPop = nRow  && set current position ...
  1731.     n_ColPop = nCol
  1732.     
  1733. RETURN .t.
  1734. *-- EoF: LocPop()
  1735.  
  1736. *-------------------------------------------------------------------------------
  1737. *-- Included below are any auxiliary routines needed for those above.
  1738. *-------------------------------------------------------------------------------
  1739.  
  1740. FUNCTION Used
  1741. *-------------------------------------------------------------------------------
  1742. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1743. *-- Date........: 02/28/1992
  1744. *-- Notes.......: Created because the picklist routine by Malcolm Rubel
  1745. *--               from DBA Magazine (11/91) calls a function that checks
  1746. *--               to see if a DBF file is open ... 
  1747. *-- Written for.: dBASE IV, 1.5
  1748. *-- Rev. History: 05/15/1992 -- Original
  1749. *--               02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
  1750. *--               a much simpler way to do this ...
  1751. *-- Called by...: Any
  1752. *-- Calls.......: None
  1753. *-- Usage.......: Used("<cFile>")
  1754. *-- Example.....: if used("Library")
  1755. *--                  select library
  1756. *--               else
  1757. *--                  select select()
  1758. *--                  use library
  1759. *--               endif
  1760. *-- Returns.....: Logical (.t. if file is in use, .f. if not)
  1761. *-- Parameters..: cFile = file to check for
  1762. *-------------------------------------------------------------------------------
  1763.     
  1764.     parameters cFile
  1765.     
  1766. RETURN (select(cFile) # 0)
  1767. *-- EoF: Used()
  1768.  
  1769. FUNCTION VidRow
  1770. *-------------------------------------------------------------------------------
  1771. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1772. *-- Date........: 01/28/1993
  1773. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1774. *--               to return the ABSOLUTE position of the current ROW on the
  1775. *--               screen, despite any active windows, etc.
  1776. *--               This is based on original routines by David Frankenbach,
  1777. *--               but includes the load/release in one routine, rather
  1778. *--               than requiring three functions to perform this ...
  1779. *--               ***************************
  1780. *--               ** REQUIRES VDCURSOR.BIN **
  1781. *--               ***************************
  1782. *-- Written for.: dBASE IV, 1.5
  1783. *-- Rev. History: 01/28/1993 -- Original Release
  1784. *-- Calls.......: VDCURSOR.BIN
  1785. *-- Called by...: Any 
  1786. *-- Usage.......: VidRow()
  1787. *-- Example.....: ?VidRow()
  1788. *-- Returns.....: Numeric ROW position for current row on screen
  1789. *-- Parameters..: None
  1790. *-------------------------------------------------------------------------------
  1791.  
  1792.     private cX
  1793.     
  1794.     cX = space(2)             && define argument memvar
  1795.     load vdcursor             && load the .BIN file
  1796.     call vdcursor with cX     && call it with the memvar
  1797.     release module vdcursor   && release from memory
  1798.  
  1799. RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
  1800. *-- EoF: VidRow()
  1801.  
  1802. FUNCTION VidCol
  1803. *-------------------------------------------------------------------------------
  1804. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1805. *-- Date........: 01/28/1993
  1806. *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
  1807. *--               to return the ABSOLUTE position of the current COLUMN on the
  1808. *--               screen, despite any active windows, etc.
  1809. *--               This is based on original routines by David Frankenbach,
  1810. *--               but includes the load/release in one routine, rather
  1811. *--               than requiring three functions to perform this ...
  1812. *--               ***************************
  1813. *--               ** REQUIRES VDCURSOR.BIN **
  1814. *--               ***************************
  1815. *-- Written for.: dBASE IV, 1.5
  1816. *-- Rev. History: 01/28/1993 -- Original Release
  1817. *-- Calls.......: VDCURSOR.BIN
  1818. *-- Called by...: Any 
  1819. *-- Usage.......: VidCol()
  1820. *-- Example.....: ?VidCol()
  1821. *-- Returns.....: Numeric COLUMN position for current Col on screen
  1822. *-- Parameters..: None
  1823. *-------------------------------------------------------------------------------
  1824.  
  1825.     private cX
  1826.     
  1827.     cX = space(2)             && define argument memvar
  1828.     load vdcursor             && load the .BIN file
  1829.     call vdcursor with cX     && call it with the memvar
  1830.     release module vdcursor   && release from memory
  1831.  
  1832. RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
  1833. *-- EoF: VidCol()
  1834.  
  1835.  
  1836. *-------------------------------------------------------------------------------
  1837. *-- End of File: PICKLIST.PRG
  1838. *-------------------------------------------------------------------------------
  1839.