home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 14 / CDACTUAL.iso / cdactual / demobin / share / program / Basic / STDLIB.ZIP / LMENU.BAS < prev    next >
Encoding:
BASIC Source File  |  1990-10-04  |  5.7 KB  |  160 lines
  1. '****************************************************************************
  2. 'Total Control Systems                                         QuickBasic 4.5
  3. '****************************************************************************
  4. '
  5. '  Program     : LMENU.BAS
  6. '  Written by  : Tim Beck
  7. '  Written On  : 10-01-90
  8. '  Function    : LOTUS STYLE MENU (SIMILAR TO POPMENUH, LEVEL 1)
  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 SUB ONSCREEN (R%, C%, msg$, csr%, attr%)
  48.  
  49.    DECLARE SUB LOTUSMENU (Row%, Col%, M$(), H$(), M.Item%, Choice%)
  50.  
  51.    '-----------------------------------------------------------------------
  52.    '  Lotus Style Menu
  53.    ' 
  54.    '  Row%, Col%  = Top Left Row and Column of Menu
  55.    '  M$()        = Menu Selections
  56.    '  H$()        = Help Text for Each Menu Item
  57.    '  M.Items%    = Number of Menu Items
  58.    '  Choice%     = Selected Option
  59.    '
  60.  
  61.  
  62.    REM $INCLUDE: 'STDCOM.INC'
  63.  
  64.    TIMER OFF    'Enables Event Trapping
  65.  
  66. '  ON ERROR GOTO ErrorTrap
  67.  
  68. ErrorTrap:
  69.  
  70. '  RESUME
  71.  
  72. SUB LOTUSMENU (Row%, Col%, M$(), H$(), M.Item%, Choice%) STATIC
  73.  
  74.    COLOR M.Fore%, M.Back%
  75.  
  76.    x1% = Col%
  77.    y1% = Row%
  78.    MB.attr% = M.Back% + (16 * M.Fore%)
  79.    MH.attr% = M.Fore% + 8 + (16 * M.Back%)
  80.  
  81.    Choices$ = ""
  82.    max.wid% = 0
  83.    M.Arrow% = 1
  84.    IF Choice% < 1 OR Choice% > M.Item% THEN
  85.       Choice% = 1
  86.    END IF
  87.  
  88.    FOR Item% = 1 TO M.Item%
  89.       IF LEN(M$(Item%)) > max.wid% THEN
  90.          max.wid% = LEN(M$(Item%))
  91.       END IF
  92.    NEXT Item%
  93.  
  94.    FOR Item% = 1 TO M.Item%
  95.       M$(Item%) = LEFT$(M$(Item%) + SPACE$(max.wid%), max.wid%)
  96.       Choices$ = Choices$ + LEFT$(M$(Item%), 1)
  97.    NEXT Item%
  98.  
  99.    IF Row% = 0 THEN
  100.       Row% = 1
  101.    END IF
  102.  
  103.    IF Col% = 0 THEN
  104.       Col% = 1
  105.    END IF
  106.  
  107.   'Locate Row%, Col%
  108.   
  109.    FOR Item% = 1 TO M.Item%
  110.      'PRINT M$(Item%); " ";
  111.       CALL PRINTA(Col% + ((Item% - 1) * (max.wid% + 1)), Row%, M.attr%, M$(Item%) + " ")
  112.    NEXT Item%
  113.  
  114.    DO
  115.       CALL ONSCREEN(Row% + 1, 2, H$(Choice%), 0, HB.attr%)
  116.       CALL PRINTA(Col% + ((Choice% - 1) * (max.wid% + 1)), Row%, MB.attr%, M$(Choice%))
  117.       COLOR M.Fore%, M.Back%
  118.       LOCATE Row%, Col% + ((Choice% - 1) * (max.wid% + 1))
  119.       IF LEN(Choices$) THEN
  120.          M.Linp$ = MID$(Choices$, Choice%, 1)
  121.          CALL GET.INPUT(Row%, Col% + ((Choice% - 1) * (max.wid% + 1)), 1, 0, 1, 1, 0, 1, CHR$(238), M.Linp$, 0, E.Flag%, kb%)
  122.       ELSE
  123.          M.Linp$ = MID$(Choices$, Choice%, 1)
  124.          CALL GET.INPUT(Row%, Col% + ((Choice% - 1) * (max.wid% + 1)), 1, 0, 1, 1, 0, 1, "", M.Linp$, 0, 1, kb%)
  125.       END IF
  126.       CALL PRINTA(Col% + ((Choice% - 1) * (max.wid% + 1)), Row%, M.attr%, M$(Choice%))
  127.       IF X% = F.10% THEN
  128.          M.Linp$ = MID$(STR$(Choice%), 2)
  129.       ELSEIF X% = Right.Arrow% THEN
  130.          IF Choice% = M.Item% THEN
  131.             Choice% = 1
  132.          ELSE
  133.             Choice% = Choice% + 1
  134.          END IF
  135.       ELSEIF X% = Left.Arrow% THEN
  136.          IF Choice% = 1 THEN
  137.             Choice% = M.Item%
  138.          ELSE
  139.             Choice% = Choice% - 1
  140.          END IF
  141.       ELSEIF E.Flag% OR X% = F.9% THEN
  142.          EXIT DO
  143.       ELSEIF LEN(RTRIM$(M.Linp$)) THEN
  144.          IF INSTR(Choices$, M.Linp$) > 0 THEN
  145.             Choice% = INSTR(Choices$, M.Linp$)
  146.             M.Linp$ = MID$(STR$(Choice%), 2)
  147.          END IF
  148.       ELSEIF X% = Enter% OR X% = Down.Arrow% THEN
  149.          M.Linp$ = MID$(STR$(Choice%), 2)
  150.       END IF
  151.    LOOP WHILE VAL(M.Linp$) = 0
  152.  
  153.    CALL PRINTA(Col% + ((Choice% - 1) * (max.wid% + 1)), Row%, MB.attr%, M$(Choice%))
  154.   
  155.    COLOR S.Fore%, S.Back%
  156.    M.Arrow% = 0
  157.  
  158. END SUB
  159.  
  160.