home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 24 / CD_ASCQ_24_0995.iso / vrac / homonlib.zip / PICKSOME.BAS < prev    next >
BASIC Source File  |  1995-04-13  |  11KB  |  293 lines
  1. DEFINT A-Z
  2.  
  3. ' $INCLUDE: 'PARM.INC'
  4. ' $INCLUDE: 'SETCURS.INC'
  5. ' $INCLUDE: 'TRUEFALS.INC'
  6.  
  7. DECLARE FUNCTION PickSome$ (choice$(), tag(), 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 PickSome$ (choice$(), tag(), parm())
  18. '****************************************************************************
  19. 'PickSome$() works just like the PickOne$() function but also allows for the
  20. ' tagging of multiple items.  See PickOne$() for general information about
  21. ' how these functions work.  Additional information on how the tagging works
  22. ' is described here.
  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. '    parm(6) = tagging key  Default=32 (spacebar)
  30. '    parm(7) = tag all key  Default=-66 (F8)
  31. '    parm(8) = tag none key  Default=-67 (F9)
  32. '    parm(9) = switch tags key  Default=-68 (F10)
  33. '    parm(10) can be specified as another hotkey (see PickOne$())
  34. '
  35. 'The tagging keys specified by parm(6 to 9) may be disabled by passing -1.
  36. ' The default will be assigned if zero is passed.
  37. ' The tagging key will toggle an individual item's tag to on (1) or off (0).
  38. ' The tag all/tag none keys will set all items' tags to on/off respectively.
  39. ' The switch tags key will change all on tags to off, and all off tags to on.
  40. '
  41. 'The tag array must be an integer array with subscripts identical to the
  42. ' choice$() array.  You may pre-tag items or disable items in the array by
  43. ' setting elements of tag() to one of the following values:
  44. '
  45. '            0 = Untagged/Off   1 = Tagged/On   -1 = Disabled
  46. '
  47. 'If an item is disabled, it will be unaffected by any tagging operations and
  48. ' will appear in the dimmed color specified by parm(FGD) and/or parm(FGDS).
  49. '
  50. '****************************************************************************
  51.  
  52. STATIC top                              'To restore for a subsequent call.
  53.  
  54. oldcursor = SetCursor(SCNONE)           'Turn the cursor off
  55.  
  56. IF parm(10) > 0 THEN                    'Hotkey specified?
  57.      hotkey$ = CHR$(parm(10))
  58. ELSEIF parm(10) < 0 THEN
  59.      hotkey$ = CHR$(0) + CHR$(-parm(10))
  60. END IF
  61.  
  62. x = parm(6)                             'Set up the tagging keys
  63. IF x = 0 THEN x = 32     'Default = spacebar
  64. GOSUB MakeTagKey
  65. tagkey$ = k$
  66. x = parm(7)
  67. IF x = 0 THEN x = -66    'Default = F8
  68. GOSUB MakeTagKey
  69. allkey$ = k$
  70. x = parm(8)
  71. IF x = 0 THEN x = -67    'Default = F9
  72. GOSUB MakeTagKey
  73. nonekey$ = k$
  74. x = parm(9)
  75. IF x = 0 THEN x = -68    'Default = F10
  76. GOSUB MakeTagKey
  77. switchkey$ = k$
  78.  
  79. REDIM t$(-1 TO 1)                       'Set up the tagging identifiers
  80. t$(-1) = " "
  81. t$(0) = " "
  82. t$(1) = CHR$(251)
  83.  
  84. min = LBOUND(choice$)                   'Get information about choice$().
  85. max = UBOUND(choice$)
  86.  
  87. REDIM temp(1 TO MAXPARM)                'Create a duplicate parameter array
  88. FOR x = MINPARM TO MAXPARM              'for calling the BorderLines() SUB.
  89.      temp(x) = parm(x)
  90. NEXT x
  91. temp(1) = parm(1)
  92. temp(2) = parm(2)
  93. temp(5) = min
  94. temp(6) = max
  95.  
  96. wide = parm(3)                          'Calculate column widths, increasing
  97. IF wide < 1 THEN                        ' the given or calculated value by 2
  98.      FOR x = min TO max                 ' to allow for separating spaces and
  99.           l = LEN(choice$(x)) + 2       ' the tag character.
  100.           IF l > wide THEN wide = l
  101.      NEXT x
  102. ELSE
  103.      wide = wide + 2
  104. END IF
  105. IF wide > 80 THEN wide = 80
  106. DO WHILE (80 MOD wide) > 0              'Make the columns fill the screen.
  107.      wide = wide + 1
  108. LOOP
  109. cols = 80 \ wide                        'Calculate # of columns
  110.  
  111. tall = parm(2) - parm(1) - 1            'Calculate # of items per column.
  112. ptot = cols * tall                      'Calculate # of items per screen.
  113.  
  114. sel = parm(4)                           'Determine initial selected element.
  115. IF sel < min THEN sel = min
  116. IF sel > max THEN sel = max
  117.  
  118.  
  119. IF parm(5) THEN top = min               'Was top Reset?  Is it valid?
  120. IF top < min OR top > max THEN top = min
  121. bot = top + ptot - 1
  122.  
  123. IF sel < top OR sel > bot THEN          'Move top & bot to fit sel if they
  124.      top = min                          'don't already do so.
  125.      bot = top + ptot - 1
  126. END IF
  127. DO WHILE sel > bot
  128.      top = top + ptot
  129.      bot = top + ptot - 1
  130. LOOP
  131. IF bot > max THEN bot = max
  132.  
  133. '    *************************  The Main Loop!  *************************
  134.  
  135. l = wide - 2                            'To allow for the separating spaces
  136.                                         ' and the tag when padding the items.
  137.  
  138. refresh = TRUE                          'Make sure the screen gets drawn!
  139.  
  140. DO
  141.  
  142.      IF refresh THEN                    'This stuff only needs to be printed
  143.           temp(3) = top                 ' occasionally (i.e., when top & bot
  144.           temp(4) = bot                 ' change).
  145.           BorderLines temp()
  146.           WipeArea parm(1) + 1, 1, parm(2) - 1, 80
  147.           refresh = FALSE
  148.      END IF
  149.  
  150.      row = parm(1) + 1: col = 1         'Show the items on screen
  151.      FOR x = top TO bot
  152.           IF tag(x) = -1 THEN COLOR parm(FGD)
  153.           IF x = sel THEN
  154.                COLOR parm(FGS), parm(BGS)
  155.                IF tag(x) = -1 THEN COLOR parm(FGDS)
  156.           END IF
  157.           LOCATE row, col: PRINT " "; PadR$(choice$(x), l); t$(tag(x))
  158.           COLOR parm(FGN), parm(BGN)
  159.           row = row + 1
  160.           IF row = parm(2) THEN row = parm(1) + 1: col = col + wide
  161.      NEXT x
  162.  
  163.      k$ = UCASE$(GetKey$(parm()))       'Get keyboard input
  164.  
  165.      SELECT CASE ASC(LEFT$(k$, 1))
  166.           CASE 13                                           'Enter
  167.                PickSome$ = Istr$(sel)
  168.                EXIT DO
  169.           CASE 27                                           'ESC
  170.                PickSome$ = ""
  171.                EXIT DO
  172.           CASE 0
  173.                SELECT CASE ASC(RIGHT$(k$, 1))
  174.                     CASE 72                                 'Up Arrow
  175.                          sel = sel - 1
  176.                     CASE 80                                 'Down Arrow
  177.                          sel = sel + 1
  178.                     CASE 75                                 'Left Arrow
  179.                          IF cols > 1 THEN
  180.                               sel = sel - tall
  181.                               IF sel < top THEN
  182.                                    sel = sel + ptot
  183.                               END IF
  184.                          END IF
  185.                     CASE 77                                 'Right Arrow
  186.                          IF cols > 1 THEN
  187.                               sel = sel + tall
  188.                               IF sel > bot THEN
  189.                                    sel = sel - ptot
  190.                               END IF
  191.                          END IF
  192.                     CASE 73                                 'PgUp
  193.                          IF top > min THEN
  194.                               top = top - ptot
  195.                               IF top < min THEN top = min
  196.                               bot = top + ptot - 1
  197.                               IF bot > max THEN bot = max
  198.                               sel = top
  199.                               refresh = TRUE
  200.                          END IF
  201.                     CASE 81                                 'PgDn
  202.                          IF bot < max THEN
  203.                               top = top + ptot
  204.                               bot = top + ptot - 1
  205.                               IF bot > max THEN bot = max
  206.                               sel = top
  207.                               refresh = TRUE
  208.                          END IF
  209.                     CASE 71                                 'Home
  210.                          sel = min
  211.                          IF top > min THEN
  212.                               top = min
  213.                               bot = top + ptot - 1
  214.                               IF bot > max THEN bot = max
  215.                               refresh = TRUE
  216.                          END IF
  217.                     CASE 79                                 'End
  218.                          sel = max
  219.                          IF bot < max THEN
  220.                               bot = max
  221.                               top = bot - ptot + 1
  222.                               IF top < min THEN top = min
  223.                               refresh = TRUE
  224.                          END IF
  225.                     CASE ELSE                               'TagKey/Hotkey?
  226.                          GOSUB HotKeys
  227.                END SELECT
  228.           CASE ELSE
  229.                GOSUB HotKeys
  230.      END SELECT
  231.  
  232.      IF sel < top THEN sel = bot
  233.      IF sel > bot THEN sel = top
  234.  
  235. LOOP
  236.  
  237. x = SetCursor(oldcursor)                'Restore cursor to previous setting.
  238. ERASE t$                                'Relinquish array memory.
  239. ERASE temp
  240.  
  241. EXIT FUNCTION                           'Avoid a RETURN WITHOUT GOSUB error!
  242.  
  243. HotKeys:
  244.      SELECT CASE k$
  245.           CASE tagkey$
  246.                IF tag(sel) <> -1 THEN
  247.                     tag(sel) = tag(sel) + 1
  248.                     IF tag(sel) > 1 THEN tag(sel) = 0
  249.                     sel = sel + 1
  250.                END IF
  251.           CASE allkey$
  252.                FOR x = min TO max
  253.                     IF tag(x) <> -1 THEN
  254.                          tag(x) = 1
  255.                     END IF
  256.                NEXT x
  257.           CASE nonekey$
  258.                FOR x = min TO max
  259.                     IF tag(x) <> -1 THEN
  260.                          tag(x) = 0
  261.                     END IF
  262.                NEXT x
  263.           CASE switchkey$
  264.                FOR x = min TO max
  265.                     IF tag(x) <> -1 THEN
  266.                          tag(x) = tag(x) + 1
  267.                          IF tag(x) > 1 THEN tag(x) = 0
  268.                     END IF
  269.                NEXT x
  270.           CASE hotkey$                       'User-defined hotkey?
  271.                PickSome$ = "*" + Istr$(parm(10)) + " " + Istr$(sel)
  272.                x = SetCursor(oldcursor)
  273.                ERASE t$
  274.                ERASE temp
  275.                EXIT FUNCTION
  276.           CASE ELSE
  277.                'Do nothing
  278.      END SELECT
  279.      RETURN
  280.  
  281. MakeTagKey:
  282.      IF x = -1 THEN                     'Disable this key
  283.           k$ = ""
  284.      ELSEIF x > 0 THEN                  'One-byte key
  285.           k$ = CHR$(x)
  286.      ELSE                               'Two-byte key
  287.           k$ = CHR$(0) + CHR$(-x)
  288.      END IF
  289.      RETURN
  290.  
  291. END FUNCTION
  292.  
  293.