home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / homonlib.zip / PICKONE.BAS < prev    next >
BASIC Source File  |  1995-04-13  |  9KB  |  240 lines
  1. DEFINT A-Z
  2.  
  3. ' $INCLUDE: 'PARM.INC'
  4. ' $INCLUDE: 'SETCURS.INC'
  5. ' $INCLUDE: 'TRUEFALS.INC'
  6.  
  7. DECLARE FUNCTION PickOne$ (choice$(), parm())
  8.  
  9. 'External procedures:
  10.  
  11. DECLARE SUB BorderLines (parm())
  12. DECLARE FUNCTION GetKey$ (parm())
  13. DECLARE FUNCTION Istr$ (i)
  14. DECLARE FUNCTION PadR$ (orig$, newlen)
  15. DECLARE SUB WipeArea (t, l, b, r)
  16.  
  17. FUNCTION PickOne$ (choice$(), parm())
  18. '****************************************************************************
  19. 'Allow the user to select an item from an array by highlighting it with the
  20. ' cursor keys & pressing Enter.  The function returns a string of the item's
  21. ' element number, or a null string if the user ESCapes.  Other options are
  22. ' available, and are specified in parm().
  23. '
  24. '    parm(1) = top row
  25. '    parm(2) = bottom row
  26. '    parm(3) = column width  0=Calculated by the function (recommended)
  27. '    parm(4) = initial selected element #
  28. '    parm(5) = reset?  0=Subsequent call  Non-zero=Reset
  29. '
  30. 'Any column width specified in parm(3) will be increased by 2 to allow for
  31. ' spaces on either side of each item.  Allow for this when supplying this
  32. ' value.
  33. '
  34. 'parm(6 to 10) are special parameters, designating "hotkeys" that will return
  35. ' control to the calling procedure, and return a string of the key pressed
  36. ' along with the element number of the currently highlighted item.  If no
  37. ' hotkey is desired, merely pass a zero for that parameter.
  38. '
  39. 'To specify a one-byte INKEY$ code, merely pass the ASCII code of the key.
  40. ' If the key is a letter, pass the upper-case ASCII code.  To specify a two-
  41. ' byte key, pass the negative ASCII code of the second byte.
  42. '
  43. ' Examples:  To specify the backspace key, pass 8 ( CHR$(8) ).
  44. '            To specify the F1 key, pass -59 ( CHR$(0)+CHR$(59) ).
  45. '
  46. 'The string returned when a hotkey is pressed will consist of an asterisk
  47. ' followed by the hotkey code specified in the parm() array, a space, and the
  48. ' current element number.
  49. '
  50. ' Example: "*-59 4" would mean that the F1 key was pressed while element #4
  51. '          was highlighted.
  52. '
  53. 'When returning to the function after processing a hotkey, make sure that
  54. ' parm(4) is updated to reflect the current element, and parm(5) is zero.
  55. ' If calling the function for the first time, make sure parm(5) is non-zero.
  56. '
  57. '****************************************************************************
  58.  
  59. STATIC top                              'To preserve the position of the pick
  60.                                         'screen between calls.
  61.  
  62. oldcursor = SetCursor(SCNONE)           'Turn the cursor off
  63.  
  64. REDIM hotkey$(6 TO 10)                  'Evaluate parm() for hotkeys.
  65. FOR x = 6 TO 10
  66.      IF parm(x) > 0 THEN
  67.           hotkey$(x) = CHR$(parm(x))
  68.      ELSEIF parm(x) < 0 THEN
  69.           hotkey$(x) = CHR$(0) + CHR$(-parm(x))
  70.      END IF
  71. NEXT x
  72.  
  73. min = LBOUND(choice$)                   'Get information about choice$().
  74. max = UBOUND(choice$)
  75.  
  76. REDIM temp(1 TO MAXPARM)                'Create a duplicate parameter array
  77. FOR x = MINPARM TO MAXPARM              'for calling the BorderLines() SUB.
  78.      temp(x) = parm(x)
  79. NEXT x
  80. temp(1) = parm(1)
  81. temp(2) = parm(2)
  82. temp(5) = min
  83. temp(6) = max
  84.  
  85. wide = parm(3)                          'Calculate column widths, increasing
  86. IF wide < 1 THEN                        ' the given or calculated value by 2
  87.      FOR x = min TO max                 ' to allow for separating spaces.
  88.           l = LEN(choice$(x)) + 2
  89.           IF l > wide THEN wide = l
  90.      NEXT x
  91. ELSE
  92.      wide = wide + 2
  93. END IF
  94. IF wide > 80 THEN wide = 80
  95. DO WHILE (80 MOD wide) > 0              'Make the columns fill the screen.
  96.      wide = wide + 1
  97. LOOP
  98. cols = 80 \ wide                        'Calculate # of columns
  99.  
  100. tall = parm(2) - parm(1) - 1            'Calculate # of items per column.
  101. ptot = cols * tall                      'Calculate # of items per screen.
  102.  
  103. sel = parm(4)                           'Determine initial selected element.
  104. IF sel < min THEN sel = min
  105. IF sel > max THEN sel = max
  106.  
  107. IF parm(5) THEN top = min               'Was top Reset?  Is it valid?
  108. IF top < min OR top > max THEN top = min
  109. bot = top + ptot - 1
  110.  
  111. IF sel < top OR sel > bot THEN          'Move top & bot to fit sel.
  112.      top = min
  113.      bot = top + ptot - 1
  114. END IF
  115. DO WHILE sel > bot
  116.      top = top + ptot
  117.      bot = top + ptot - 1
  118. LOOP
  119. IF bot > max THEN bot = max
  120.  
  121. '    *************************  The Main Loop!  *************************
  122.  
  123. l = wide - 2                            'To allow for the separating spaces
  124.                                         ' when padding the items.
  125.  
  126. refresh = TRUE                          'Make sure the screen gets drawn!
  127.  
  128. DO
  129.  
  130.      IF refresh THEN                    'This stuff only needs to be printed
  131.           temp(3) = top                 ' occasionally (i.e., when top & bot
  132.           temp(4) = bot                 ' change).
  133.           BorderLines temp()
  134.           WipeArea parm(1) + 1, 1, parm(2) - 1, 80
  135.           refresh = FALSE
  136.      END IF
  137.  
  138.      row = parm(1) + 1: col = 1         'Show the items on screen
  139.      FOR x = top TO bot
  140.           IF x = sel THEN COLOR parm(FGS), parm(BGS)
  141.           LOCATE row, col: PRINT " "; PadR$(choice$(x), l); " "
  142.           COLOR parm(FGN), parm(BGN)
  143.           row = row + 1
  144.           IF row = parm(2) THEN row = parm(1) + 1: col = col + wide
  145.      NEXT x
  146.  
  147.      k$ = UCASE$(GetKey$(parm()))       'Get keyboard input
  148.      SELECT CASE ASC(LEFT$(k$, 1))
  149.           CASE 13                                           'Enter
  150.                PickOne$ = Istr$(sel)
  151.                EXIT DO
  152.           CASE 27                                           'ESC
  153.                PickOne$ = ""
  154.                EXIT DO
  155.           CASE 0
  156.                SELECT CASE ASC(RIGHT$(k$, 1))
  157.                     CASE 72                                 'Up Arrow
  158.                          sel = sel - 1
  159.                     CASE 80                                 'Down Arrow
  160.                          sel = sel + 1
  161.                     CASE 75                                 'Left Arrow
  162.                          IF cols > 1 THEN
  163.                               sel = sel - tall
  164.                               IF sel < top THEN
  165.                                    sel = sel + ptot
  166.                               END IF
  167.                          END IF
  168.                     CASE 77                                 'Right Arrow
  169.                          IF cols > 1 THEN
  170.                               sel = sel + tall
  171.                               IF sel > bot THEN
  172.                                    sel = sel - ptot
  173.                               END IF
  174.                          END IF
  175.                     CASE 73                                 'PgUp
  176.                          IF top > min THEN
  177.                               top = top - ptot
  178.                               IF top < min THEN top = min
  179.                               bot = top + ptot - 1
  180.                               IF bot > max THEN bot = max
  181.                               sel = top
  182.                               refresh = TRUE
  183.                          END IF
  184.                     CASE 81                                 'PgDn
  185.                          IF bot < max THEN
  186.                               top = top + ptot
  187.                               bot = top + ptot - 1
  188.                               IF bot > max THEN bot = max
  189.                               sel = top
  190.                               refresh = TRUE
  191.                          END IF
  192.                     CASE 71                                 'Home
  193.                          sel = min
  194.                          IF top > min THEN
  195.                               top = min
  196.                               bot = top + ptot - 1
  197.                               IF bot > max THEN bot = max
  198.                               refresh = TRUE
  199.                          END IF
  200.                     CASE 79                                 'End
  201.                          sel = max
  202.                          IF bot < max THEN
  203.                               bot = max
  204.                               top = bot - ptot + 1
  205.                               IF top < min THEN top = min
  206.                               refresh = TRUE
  207.                          END IF
  208.                     CASE ELSE                               'Hotkey?
  209.                          GOSUB HotKeys
  210.                END SELECT
  211.           CASE ELSE
  212.                GOSUB HotKeys
  213.      END SELECT
  214.  
  215.      IF sel < top THEN sel = bot
  216.      IF sel > bot THEN sel = top
  217.  
  218. LOOP
  219.  
  220. x = SetCursor(oldcursor)                'Restore cursor to previous setting
  221. ERASE hotkey$                           'Relinquish array memory
  222. ERASE temp
  223.  
  224. EXIT FUNCTION                           'Avoid a RETURN WITHOUT GOSUB error!
  225.  
  226. HotKeys:
  227.      FOR x = 6 TO 10
  228.           IF k$ = hotkey$(x) THEN
  229.                PickOne$ = "*" + Istr$(parm(x)) + " " + Istr$(sel)
  230.                x = SetCursor(oldcursor)
  231.                ERASE hotkey$
  232.                ERASE temp
  233.                EXIT FUNCTION
  234.           END IF
  235.      NEXT x
  236.      RETURN
  237.  
  238. END FUNCTION
  239.  
  240.