home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 14 / CDACTUAL.iso / cdactual / demobin / share / program / Basic / STDLIB.ZIP / BOXMENU.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-10-04  |  8.1 KB  |  232 lines
  1. '****************************************************************************
  2. 'Total Control Systems                                         QuickBasic 4.5
  3. '****************************************************************************
  4. '
  5. '  Program     : BOXMENU.BAS
  6. '  Written by  : Tim Beck
  7. '  Written On  : 10-01-90
  8. '  Function    : BOX MENU SUBROUTINE
  9. '
  10. '****************************************************************************
  11. '  This program and those associated with it were written for use with Quick-
  12. '  Windows Advanced (Version 1.5+).  Possesion of this program entitles you
  13. '  to certain priviliges.  They are:
  14. '
  15. '     1. You may compile, use, or modify this program in any way you choose
  16. '        provided you do not sell or give away the source code to this prog-
  17. '        ram or any of it's companions to anyone for any reason.  You may,
  18. '        however, sell the resulting executable program as you see fit.
  19. '
  20. '     2. You may modify, enhance or change these programs as you see fit. I
  21. '        as that you keep a copy of the original code and that you notify
  22. '        me of any improvements you make.  I like to think that the code is
  23. '        bug free and cannot be improved upon, but I'm sure someone will
  24. '        find a way to make it better.  If it's you, I'm looking forward to
  25. '        seeing your changes.  I can be reached at:
  26. '
  27. '              Tim Beck                      Tim Beck (C/O Debbie Beck)
  28. '              19419 Franz Road              8030 Fairchild Avenue
  29. '              Houston, Texas  77084         Canoga Park, California 91306
  30. '              (713) 639-3079                (818) 998-0588
  31. '
  32. '     3. This code has been tested and re-tested in a variety of applications
  33. '        and although I have not found any bugs, doesn't mean none exist. So,
  34. '        this program along with it's companions comes with NO WARRANTY,
  35. '        either expressed or implied.  I'm sorry if there are problems, but
  36. '        I can't be responsible for your work.  I've tried to provide a safe
  37. '        and efficient programming enviroment and I hope you find it helpful
  38. '        for you.  I do, however, need to cover my butt!
  39. '
  40. '  I have enjoyed creating this library of programs and have found them to be
  41. '  a great time saver.  I hope you agree.
  42. '
  43. '                                                            Tim Beck //
  44. '
  45. '****************************************************************************
  46.    DECLARE SUB GET.INPUT (Row%, Col%, C.pos%, C.type%, AR.Flag%, C.Flag%, Blank%, I.Color%, Format$, Linp$, M.len%, E.flag%, kb%)
  47.    DECLARE FUNCTION Show$ (Show.String$, Show.Len%)
  48.  
  49.    DECLARE SUB BOX.MENU (Row%, Col%, Hdr$, Menu%, M$(), H$(), Choice%, Allow.Exit%, Prompt%)
  50.  
  51.    '------------------------------------------------------------------------
  52.    '  Create a Boxed Vertical Menu - Return Selected Option
  53.    '
  54.    '  Row%, Col%  = Top Left Row and Column of Menu (0,0 = Centered on Screen)
  55.    '  Hdr$        = Menu Header Text (ie: MAIN MENU)
  56.    '  Menu%       = Number of Menu Items
  57.    '  M$()        = Menu Item Array
  58.    '  H$()        = Help Text for Each Menu Item (Prints on Line 23)
  59.    '  Choice%     = Number of Selected Item
  60.    '  Allow.Exit% = Allow [ESC] to Exit Menu
  61.    '  Prompt%     = Print "Your Choice: " prompt two lines beneath Menu
  62.    '
  63.  
  64.    REM $INCLUDE: 'STDCOM.INC'
  65.  
  66.    TIMER OFF    'Enables Event Trapping
  67.  
  68. '   ON ERROR GOTO ErrorTrap
  69.  
  70. ErrorTrap:
  71.  
  72. '   RESUME
  73.  
  74. SUB BOX.MENU (Row%, Col%, Hdr$, Menu%, M$(), H$(), Choice%, Allow.Exit%, Prompt%) STATIC
  75.  
  76.    COLOR M.Fore%, M.Back%
  77.  
  78.    Choices$ = ""
  79.    max.wid% = 0
  80.    Style% = Sh.Flag% + EX.Flag% + 8
  81.    Style2% = Sh.Flag% + EX.Flag% + 1
  82.  
  83.    IF Choice% = 0 THEN
  84.       Choice% = 1
  85.    END IF
  86.  
  87.    FOR Item% = 1 TO Menu%
  88.       IF LEN(M$(Item%)) > max.wid% THEN
  89.          max.wid% = LEN(M$(Item%))
  90.       END IF
  91.    NEXT Item%
  92.  
  93.    Dup.items% = 0
  94.    FOR Item% = 1 TO Menu%
  95.       M$(Item%) = LEFT$(M$(Item%) + SPACE$(max.wid%), max.wid%)
  96.       IF INSTR(Choices$, LEFT$(M$(Item%), 1)) > 0 THEN
  97.          Dup.items% = 1
  98.       END IF
  99.       Choices$ = Choices$ + LEFT$(M$(Item%), 1)
  100.    NEXT Item%
  101.  
  102.    IF Row% = 0 AND Col% = 0 AND LEN(P.msg$) THEN
  103.       PB.attr% = M.Fore% + (16 * M.Back%)
  104.       x1% = 38 - (LEN(P.msg$) / 2)
  105.       x2% = x1% + LEN(P.msg$) + 3
  106.       IF LEN(Hdr$) THEN
  107.          y1% = 10 - Menu%
  108.          y2% = y1% + 2
  109.       ELSE
  110.          y1% = 12 - Menu%
  111.          y2% = y1% + 2
  112.       END IF
  113.       CALL QBOX(x1%, y1%, x2%, y2%, Style2%, M.attr%, "")
  114.      'CALL PRINTA(x1% + 2, y1% + 1, S.Fore% + 8, P.msg$)
  115.       CALL PRINTA(x1% + 2, y1% + 1, PB.attr%, P.msg$)
  116.       COLOR M.Fore%, M.Back%
  117.    END IF
  118.  
  119.    IF Row% = 0 THEN
  120.       Row% = (12 - Menu% + 3)
  121.    END IF
  122.  
  123.    IF Col% = 0 THEN
  124.       Col% = (40 - (max.wid% / 2)) - 2
  125.    END IF
  126.  
  127.    IF LEN(Hdr$) THEN
  128.       IF LEN(Hdr$) >= max.wid% THEN
  129.          Hdr$ = LEFT$(Hdr$, max.wid%)
  130.       ELSE
  131.          hsp% = ((max.wid% / 2) - (LEN(Hdr$) / 2)) + 1
  132.          Hdr$ = Show$(SPACE$(hsp%) + Hdr$, max.wid% + 2)
  133.       END IF
  134.       x1% = Col%
  135.       y1% = Row%
  136.       x2% = Col% + max.wid% + 3
  137.       y2% = Row% + Menu% + 3
  138.       dx% = x1% + ((max.wid% / 2) - (LEN(LetDate$) / 2)) + 2
  139.       CALL PRINTA(dx%, y1% - 1, S.attr%, LetDate$)
  140.       CALL QBOX(x1%, y1%, x2%, y2%, Style%, M.attr%, "")
  141.       CALL PRINTA(x1% + 1, y1% + 1, HB.attr%, Hdr$)
  142.       CALL QLINE(x1%, y1% + 2, x2%, y1% + 2, 1, M.attr%, 1)
  143.       Row% = Row% + 2
  144.    ELSE
  145.       x1% = Col%
  146.       y1% = Row%
  147.       x2% = Col% + max.wid% + 3
  148.       y2% = Row% + Menu% + 1
  149.       dx% = x1% + ((max.wid% / 2) - (LEN(LetDate$) / 2)) + 2
  150.       CALL PRINTA(dx%, y1% - 1, S.attr%, LetDate$)
  151.       CALL QBOX(x1%, y1%, x2%, y2%, Style%, M.attr%, "")
  152.    END IF
  153.  
  154.    x1% = Col%
  155.    y1% = Row%
  156.    IF MB.attr% = 0 THEN
  157.       IF M.Fore% > 7 THEN
  158.          MB.attr% = M.Back% + (16 * (M.Fore% - 8))
  159.       ELSE
  160.          MB.attr% = M.Back% + (16 * M.Fore%)
  161.       END IF
  162.    END IF
  163.   
  164.    IF M.Fore% <= 7 THEN
  165.       MH.attr% = M.Fore% + 8 + (16 * M.Back%)
  166.    ELSE
  167.       MH.attr% = M.Back% + (16 * (M.Fore% - 8))
  168.    END IF
  169.   
  170.    FOR Item% = 1 TO Menu%
  171.       CALL PRINTA(x1% + 2, y1% + Item%, MH.attr%, LEFT$(M$(Item%), 1))
  172.       CALL PRINTA(x1% + 3, y1% + Item%, M.attr%, MID$(M$(Item%), 2))
  173.    NEXT Item%
  174.  
  175.    DO
  176.       CALL PRINTA(x1% + 2, y1% + Choice%, MB.attr%, M$(Choice%))
  177.       CALL PRINTA(2, 23, H.attr%, Show$(H$(Choice%), 78))
  178.       COLOR S.Fore%, S.Back%
  179.       IF Prompt% THEN
  180.          CRow% = Row% + Menu% + 3
  181.          CCol% = 46
  182.          CALL PRINTA(33, Row% + Menu% + 3, S.attr%, "Your Choice: ")
  183.          M.linp$ = " "
  184.       ELSE
  185.          CRow% = Row% + Choice%
  186.          CCol% = Col% + 2
  187.          M.linp$ = MID$(Choices$, Choice%, 1)
  188.       END IF
  189.       CALL GET.INPUT(CRow%, CCol%, 1, Prompt% * 4, 1, 1, 0, 1, CHR$(238), M.linp$, 0, E.flag%, X%)
  190.       CALL PRINTA(x1% + 2, y1% + Choice%, MH.attr%, LEFT$(M$(Choice%), 1))
  191.       CALL PRINTA(x1% + 3, y1% + Choice%, M.attr%, MID$(M$(Choice%), 2))
  192.       IF X% = Down.Arrow% THEN
  193.          IF Choice% = Menu% THEN
  194.             Choice% = 1
  195.          ELSE
  196.             Choice% = Choice% + 1
  197.          END IF
  198.       ELSEIF X% = Up.Arrow% THEN
  199.          IF Choice% = 1 THEN
  200.             Choice% = Menu%
  201.          ELSE
  202.             Choice% = Choice% - 1
  203.          END IF
  204.       ELSEIF X% = Enter% THEN
  205.          M.linp$ = MID$(STR$(Choice%), 2)
  206.       ELSEIF LEN(RTRIM$(M.linp$)) AND E.flag% = 0 THEN
  207.          IF INSTR(Choices$, M.linp$) > 0 THEN
  208.             IF Dup.items% THEN
  209.                IF INSTR(Choice% + 1, Choices$, M.linp$) > 0 THEN
  210.                   Choice% = INSTR(Choice% + 1, Choices$, M.linp$)
  211.                ELSE
  212.                   Choice% = INSTR(Choices$, M.linp$)
  213.                END IF
  214.             ELSE
  215.                Choice% = INSTR(Choices$, M.linp$)
  216.                M.linp$ = MID$(STR$(Choice%), 2)
  217.             END IF
  218.          END IF
  219.       ELSEIF E.flag% AND Allow.Exit% THEN
  220.          Choice% = 0
  221.          COLOR S.Fore%, S.Back%
  222.          EXIT SUB
  223.       ELSEIF E.flag% = 0 THEN
  224.          M.linp$ = MID$(STR$(Choice%), 2)
  225.       END IF
  226.    LOOP WHILE VAL(M.linp$) = 0
  227.  
  228.    COLOR S.Fore%, S.Back%
  229.  
  230. END SUB
  231.  
  232.