home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / homonlib.zip / LISTBOX.BAS < prev    next >
BASIC Source File  |  1995-04-13  |  8KB  |  229 lines
  1. DEFINT A-Z
  2.  
  3. ' $INCLUDE: 'PARM.INC'
  4. ' $INCLUDE: 'SETCURS.INC'
  5.  
  6. DECLARE FUNCTION ListBox (title$, choice$(), parm())
  7.  
  8. 'External procedures:
  9.  
  10. DECLARE SUB Box (t, l, b, r, b$)
  11. DECLARE SUB BoxCalc (t, l, b, r, tall, wide)
  12. DECLARE FUNCTION GetKey$ (parm())
  13. DECLARE FUNCTION PadR$ (t$, l)
  14. DECLARE FUNCTION Istr$ (i)
  15. DECLARE SUB RestScreen (f$)
  16. DECLARE SUB SaveScreen (f$)
  17. DECLARE SUB SetView (t, b, parm())
  18. DECLARE FUNCTION TempName$ (p$)
  19. DECLARE FUNCTION VPage (p)
  20.  
  21. FUNCTION ListBox (title$, choice$(), parm())
  22. '****************************************************************************
  23. 'ListBox() works just like PickOne(), but it appears in a pop-up box.  It
  24. ' returns the element number of the item selected or zero if the user pressed
  25. ' ESC.  There are no hotkeys in ListBox().
  26. '
  27. 'The title$ argument will be centered on the top border of the box.  If no
  28. ' title is desired, pass a null string.
  29. '
  30. 'The width of the box is determined by the longer of the title or longest
  31. ' choice$() element.
  32. '
  33. '    parm(1) = top row  0=Center
  34. '    parm(2) = left column  0=Center
  35. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  36. '    parm(4) = initial selected choice
  37. '
  38. '****************************************************************************
  39.  
  40. '                     *** Preliminary calculations ***
  41.  
  42. min = LBOUND(choice$)                   'Get information about choice$().
  43. max = UBOUND(choice$)
  44.  
  45. wide = LEN(title$)                      'Find out how wide & tall to make the
  46. IF wide > 0 THEN wide = wide + 2        'box.  Allow for the title's frame.
  47. FOR x = min TO max
  48.      tall = tall + 1
  49.      l = LEN(choice$(x))
  50.      IF l > wide THEN wide = l
  51. NEXT x
  52. IF tall > 10 THEN tall = 10
  53.  
  54. row1 = parm(1)                          'Find out where to place the box.
  55. col1 = parm(2)
  56. BoxCalc row1, col1, row2, col2, tall, wide
  57.  
  58. '                          *** Draw the Box ***
  59.  
  60. oldrow = CSRLIN                         'Save the current cursor location
  61. oldcol = POS(0)
  62. oldcursor = SetCursor(SCNONE)           'Turn the cursor off
  63. savepage = VPage(0)                     'Allocate a video page to save the
  64. IF savepage = 0 THEN                    'current screen on.  If unable to get
  65.      savefile$ = TempName$("")          'one, we'll have to use the slower
  66.      SaveScreen savefile$               'method of saving it to an actual
  67. ELSE                                    'file.
  68.      PCOPY 0, savepage
  69. END IF
  70. workpage = VPage(0)                     'Allocate a non-critical video page.
  71. PCOPY 0, workpage                       'Copy the screen to the scratch page.
  72. SCREEN , , workpage, 0                  'Draw on the work page until ready.
  73.  
  74. COLOR parm(FGWB), parm(BGWB)            'Draw the outline & title
  75. Box row1, col1, row2, col2, Istr$(parm(3))
  76. SELECT CASE parm(3)
  77.      CASE 2
  78.           lc$ = CHR$(181)
  79.           rc$ = CHR$(198)
  80.           v$ = CHR$(186)
  81.      CASE 3
  82.           lc$ = CHR$(181)
  83.           rc$ = CHR$(198)
  84.           v$ = CHR$(179)
  85.      CASE 4
  86.           lc$ = CHR$(180)
  87.           rc$ = CHR$(195)
  88.           v$ = CHR$(186)
  89.      CASE ELSE
  90.           lc$ = CHR$(180)
  91.           rc$ = CHR$(195)
  92.           v$ = CHR$(179)
  93. END SELECT
  94. IF LEN(title$) THEN
  95.      x = wide - (LEN(title$) + 2)
  96.      LOCATE row1, col1 + (x \ 2) + 1
  97.      PRINT lc$; title$; rc$;
  98. END IF
  99.  
  100. COLOR 0, 0                              'Print the shadow
  101. l = col2 + 1
  102. FOR x = (row1 + 1) TO row2
  103.      LOCATE x, l: PRINT " "
  104. NEXT x
  105. LOCATE row2 + 1, col1 + 1: PRINT SPACE$(wide + 2);
  106.  
  107. PCOPY workpage, 0                       'Pop the box onto the screen.
  108. SCREEN , , 0, 0                         'Draw on screen 0 again.
  109. x = VPage(workpage)                     'Release the scratch video page.
  110.  
  111. '                    *** Pick a choice, any choice! ***
  112.  
  113. sel = parm(4)                           'Initially position the list.
  114. IF sel < min OR sel > max THEN sel = min
  115. top = min
  116. bot = top + tall - 1
  117. DO WHILE bot < sel
  118.      top = top + 1
  119.      bot = bot + 1
  120. LOOP
  121. col = col1 + 1
  122.  
  123. id$ = CHR$(18)                          'The little indicator character.
  124. irow = row1 + 1
  125.  
  126. COLOR parm(FGWT), parm(BGWT)
  127.  
  128. DO                                      'The main loop!
  129.     
  130.      row = row1                         'Print the choices.
  131.      FOR x = top TO bot
  132.           row = row + 1
  133.           IF x = sel THEN COLOR parm(FGWS), parm(BGWS)
  134.           LOCATE row, col
  135.           PRINT PadR$(choice$(x), wide)
  136.           COLOR parm(FGWT), parm(BGWT)
  137.      NEXT x
  138.  
  139.      IF tall = 10 THEN                  'Put an indicator on the side.
  140.           COLOR parm(FGWB), parm(BGWB)
  141.           LOCATE irow, col2
  142.           PRINT v$;
  143.           x = INT((sel / max) * 10)
  144.           IF x < 1 THEN x = 1
  145.           irow = row1 + x
  146.           LOCATE irow, col2
  147.           PRINT id$;
  148.           COLOR parm(FGWT), parm(BGWT)
  149.      END IF
  150.  
  151.      k$ = GetKey$(parm())               'Get keyboard input
  152.  
  153.      SELECT CASE ASC(LEFT$(k$, 1))
  154.           CASE 27                            'ESC
  155.                ListBox = 0
  156.                EXIT DO
  157.           CASE 13                            'Enter
  158.                ListBox = sel
  159.                EXIT DO
  160.           CASE 0
  161.                SELECT CASE ASC(RIGHT$(k$, 1))
  162.                     CASE 72                  'Up arrow
  163.                          sel = sel - 1
  164.                          IF sel < min THEN sel = min
  165.                          IF sel < top THEN
  166.                               top = top - 1
  167.                               bot = bot - 1
  168.                          END IF
  169.                     CASE 80                  'Down arrow
  170.                          sel = sel + 1
  171.                          IF sel > max THEN sel = max
  172.                          IF sel > bot THEN
  173.                               top = top + 1
  174.                               bot = bot + 1
  175.                          END IF
  176.                     CASE 73                  'PgUp
  177.                          IF top > min THEN
  178.                               top = top - tall
  179.                               bot = bot - tall
  180.                               IF top < min THEN
  181.                                    top = min
  182.                                    bot = top + tall - 1
  183.                               END IF
  184.                               IF sel > bot THEN sel = bot
  185.                          END IF
  186.                     CASE 81                  'PgDn
  187.                          IF bot < max THEN
  188.                               top = top + tall
  189.                               bot = bot + tall
  190.                               IF bot > max THEN
  191.                                    bot = max
  192.                                    top = bot - tall + 1
  193.                               END IF
  194.                               IF sel < top THEN sel = top
  195.                          END IF
  196.                     CASE 71                  'Home
  197.                          sel = min
  198.                          top = min
  199.                          bot = top + tall - 1
  200.                     CASE 79                  'End
  201.                          sel = max
  202.                          bot = max
  203.                          top = bot - tall + 1
  204.                     CASE ELSE
  205.                          'Ignore it
  206.                END SELECT
  207.           CASE ELSE
  208.                'Ignore it
  209.      END SELECT
  210.  
  211. LOOP
  212.  
  213. '                     *** Clean up after ourselves ***
  214.  
  215. IF savepage = 0 THEN                    'Restore the previous screen.
  216.      RestScreen savefile$
  217.      KILL savefile$
  218. ELSE
  219.      PCOPY savepage, 0
  220.      x = VPage(savepage)
  221. END IF
  222. x = SetCursor(oldcursor)                'Restore the cursor.
  223. COLOR parm(FGN), parm(BGN)              'Set colors to normal.
  224. SetView -1, -1, parm()                  'Restore the previous viewport.
  225. LOCATE oldrow, oldcol                   'Put the cursor back where it was.
  226.  
  227. END FUNCTION
  228.  
  229.