home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / homonlib.zip / PICKBOX.BAS < prev    next >
BASIC Source File  |  1995-04-13  |  9KB  |  271 lines
  1. DEFINT A-Z
  2.  
  3. ' $INCLUDE: 'PARM.INC'
  4. ' $INCLUDE: 'SETCURS.INC'
  5. ' $INCLUDE: 'TRUEFALS.INC'
  6.  
  7. DECLARE FUNCTION PickBox (msg$(), choice$(), parm())
  8. DECLARE SUB InfoBox (msg$(), parm())
  9. DECLARE SUB InfoBox2 (msg$, parm())
  10. DECLARE FUNCTION YesNo (msg$(), yesword$, noword$, parm())
  11. DECLARE FUNCTION YesNo2 (msg$, yesword$, noword$, parm())
  12.  
  13. 'External procedures:
  14.  
  15. DECLARE SUB BoxCalc (t, l, b, r, tall, wide)
  16. DECLARE FUNCTION GetKey$ (parm())
  17. DECLARE SUB PopBox (t, l, b, r, wide, msg$(), parm())
  18. DECLARE SUB RestScreen (f$)
  19. DECLARE SUB SaveScreen (f$)
  20. DECLARE SUB SetView (t, b, parm())
  21. DECLARE FUNCTION TempName$ (p$)
  22. DECLARE FUNCTION VPage (p)
  23.  
  24. SUB InfoBox (msg$(), parm())
  25. '****************************************************************************
  26. 'Displays the text of the msg$() array in a pop-up box.  Basically, it is
  27. ' just a call to PickBox() with only one option of " Ok ".
  28. '
  29. '    parm(1) = top left row  0=Center
  30. '    parm(2) = top left column  0=Center
  31. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  32. '    parm(4) = message justification  <0=Left  0=Center  >0=Right
  33. '
  34. 'See function PickBox() for more detailed information.
  35. '
  36. '****************************************************************************
  37.  
  38. REDIM choice$(1 TO 1)
  39. choice$(1) = " Ok "
  40.  
  41. x = PickBox(msg$(), choice$(), parm())
  42.  
  43. ERASE choice$
  44.  
  45. END SUB
  46.  
  47. SUB InfoBox2 (msg$, parm())
  48. '****************************************************************************
  49. 'Works just like InfoBox() but accepts a single text string rather than an
  50. ' array.
  51. '
  52. '    parm(1) = top left row  0=Center
  53. '    parm(2) = top left column  0=Center
  54. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  55. '    parm(4) = message justification  <0=Left  0=Center  >0=Right
  56. '
  57. 'See functions InfoBox() and PickBox() for more detailed information.
  58. '
  59. '****************************************************************************
  60.  
  61. REDIM msg$(1 TO 1)
  62. msg$(1) = msg$
  63.  
  64. REDIM choice$(1 TO 1)
  65. choice$(1) = " Ok "
  66.  
  67. x = PickBox(msg$(), choice$(), parm())
  68.  
  69. ERASE msg$
  70. ERASE choice$
  71.  
  72. END SUB
  73.  
  74. FUNCTION PickBox (msg$(), choice$(), parm())
  75. '****************************************************************************
  76. 'Allows the user to pick from a horizontal light-bar menu within a pop-up
  77. ' message box.
  78. '
  79. 'The informational text of the box is contained within the msg$() array.
  80. '
  81. 'The choice$() array contains the items the user may pick from.  The function
  82. ' will return the element number of the item selected, or zero if the user
  83. ' presses ESC.
  84. '
  85. '    parm(1) = top left row  0=Center
  86. '    parm(2) = top left column  0=Center
  87. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  88. '    parm(4) = message justification  <0=Left  0=Center  >0=Right
  89. '    parm(5) = initial selected choice
  90. '
  91. 'If a combination of any of the above parameters causes a portion of the box
  92. ' to exceed the screen boundaries, a run-time error will occur.
  93. '
  94. '****************************************************************************
  95.  
  96. '                     *** Preliminary Calculations ***
  97.  
  98. minc = LBOUND(choice$)                  'Get info about the choice array.
  99. maxc = UBOUND(choice$)
  100.  
  101. wide = 0: tall = 0                      'Find out how wide and tall to make
  102. FOR x = LBOUND(msg$) TO UBOUND(msg$)    'the box.  Use either the longest
  103.      l = LEN(msg$(x))                   'message or the combined width of all
  104.      IF l > wide THEN wide = l          'the choices to measure the width.
  105.      tall = tall + 1
  106. NEXT x
  107. tall = tall + 2                         'Allow for a blank line & choices.
  108. l = 0
  109. FOR x = minc TO maxc
  110.      l = l + LEN(choice$(x)) + 1        'Allow for spaces between choices.
  111. NEXT x
  112. l = l - 1
  113. IF l > wide THEN wide = l
  114.  
  115. row1 = parm(1)                          'Calculate where to place the box.
  116. col1 = parm(2)
  117. BoxCalc row1, col1, row2, col2, tall, wide
  118.  
  119. IF l = wide THEN                        'Calculate the column & row at which
  120.      ccol = col1 + 1                    'the choices will begin.
  121. ELSE
  122.      ccol = col1 + 1 + ((wide - l) \ 2)
  123. END IF
  124. crow = row2 - 1
  125.  
  126. '                          *** Draw the Box ***
  127.  
  128. oldrow = CSRLIN                         'Save the current cursor location
  129. oldcol = POS(0)
  130. oldcursor = SetCursor(SCNONE)           'Turn the cursor off
  131. savepage = VPage(0)                     'Allocate a video page to save the
  132. IF savepage = 0 THEN                    'current screen on.  If unable to get
  133.      savefile$ = TempName$("")          'one, we'll have to use the slower
  134.      SaveScreen savefile$               'method of saving it to an actual
  135. ELSE                                    'file.
  136.      PCOPY 0, savepage
  137. END IF
  138.  
  139. PopBox row1, col1, row2, col2, wide, msg$(), parm()
  140.  
  141. '                     *** Pick one of the choices ***
  142.  
  143. COLOR parm(FGWT), parm(BGWT)
  144. sel = parm(5)
  145.  
  146. DO                                      'The main loop to pick a choice.
  147.  
  148.      IF sel < minc THEN sel = maxc
  149.      IF sel > maxc THEN sel = minc
  150.  
  151.      LOCATE crow, ccol                  'Print the choices.
  152.      FOR x = minc TO maxc
  153.           IF x = sel THEN COLOR parm(FGWS), parm(BGWS)
  154.           PRINT choice$(x);
  155.           COLOR parm(FGWT), parm(BGWT)
  156.           IF x < maxc THEN PRINT " ";
  157.      NEXT x
  158.  
  159.      k$ = GetKey$(parm())                         'Get keyboard input:
  160.      SELECT CASE ASC(LEFT$(k$, 1))
  161.           CASE 27                                      'ESC
  162.                PickBox = 0
  163.                EXIT DO
  164.           CASE 13                                      'Enter
  165.                PickBox = sel
  166.                EXIT DO
  167.           CASE 0
  168.                SELECT CASE ASC(RIGHT$(k$, 1))
  169.                     CASE 75                            'Left Arrow
  170.                          sel = sel - 1
  171.                     CASE 77                            'Right Arrow
  172.                          sel = sel + 1
  173.                     CASE ELSE
  174.                          'Ignore it
  175.                END SELECT
  176.           CASE ELSE
  177.                'Ignore it
  178.      END SELECT
  179.  
  180. LOOP
  181.  
  182. '                     *** Clean up after ourselves ***
  183.  
  184. IF savepage = 0 THEN                    'Restore the previous screen.
  185.      RestScreen savefile$
  186.      KILL savefile$
  187. ELSE
  188.      PCOPY savepage, 0
  189.      x = VPage(savepage)
  190. END IF
  191. x = SetCursor(oldcursor)                'Restore the cursor.
  192. COLOR parm(FGN), parm(BGN)              'Set colors to normal.
  193. SetView -1, -1, parm()                  'Restore the previous viewport.
  194. LOCATE oldrow, oldcol                   'Put the cursor back where it was.
  195.  
  196. END FUNCTION
  197.  
  198. FUNCTION YesNo (msg$(), yesword$, noword$, parm())
  199. '****************************************************************************
  200. 'Works like PickBox() but returns TRUE if the yes option is selected or FALSE
  201. ' if the no option is selected or ESC is pressed.
  202. '
  203. '    parm(1) = top left row  0=Center
  204. '    parm(2) = top left column  0=Center
  205. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  206. '    parm(4) = message justification  <0=Left  0=Center  >0=Right
  207. '    parm(5) = initial selected choice as TRUE or FALSE
  208. '
  209. 'The function defaults to the words " Yes " and " No ".  If these are what
  210. ' you want, pass null strings for the optional words.  Common alternatives
  211. ' might be " Ok " and " Cancel ".
  212. '
  213. 'See function PickBox() for more detailed information.
  214. '
  215. '****************************************************************************
  216.  
  217. REDIM choice$(-1 TO 0)                  'Notice how we trick PickBox into
  218. IF LEN(yesword$) THEN                   'returning TRUE/FALSE values by
  219.      choice$(-1) = yesword$             'creating an array with the proper
  220. ELSE                                    'subscript values.
  221.      choice$(-1) = " Yes "
  222. END IF
  223. IF LEN(noword$) THEN
  224.      choice$(0) = noword$
  225. ELSE
  226.      choice$(0) = " No "
  227. END IF
  228.  
  229. YesNo = PickBox(msg$(), choice$(), parm())
  230.  
  231. ERASE choice$
  232.  
  233. END FUNCTION
  234.  
  235. FUNCTION YesNo2 (msg$, yesword$, noword$, parm())
  236. '****************************************************************************
  237. 'Works like YesNo() but accepts a single message string rather than an array.
  238. '
  239. '    parm(1) = top left row  0=Center
  240. '    parm(2) = top left column  0=Center
  241. '    parm(3) = box border type 1-4.  See SUB Panes() for numeric boxtypes.
  242. '    parm(4) = message justification  <0=Left  0=Center  >0=Right
  243. '    parm(5) = initial selected choice as TRUE or FALSE
  244. '
  245. 'See functions YesNo() and PickBox() for more detailed information.
  246. '
  247. '****************************************************************************
  248.  
  249. REDIM msg$(1 TO 1)
  250. msg$(1) = msg$
  251.  
  252. REDIM choice$(-1 TO 0)
  253. IF LEN(yesword$) THEN
  254.      choice$(-1) = yesword$
  255. ELSE
  256.      choice$(-1) = " Yes "
  257. END IF
  258. IF LEN(noword$) THEN
  259.      choice$(0) = noword$
  260. ELSE
  261.      choice$(0) = " No "
  262. END IF
  263.  
  264. YesNo2 = PickBox(msg$(), choice$(), parm())
  265.  
  266. ERASE msg$
  267. ERASE choice$
  268.  
  269. END FUNCTION
  270.  
  271.