CD Actual 14/CDACTUAL.iso/cdactual/demobin/share/program/Basic/QMENU7.ZIP/MENUWIND.BAS

BASIC Source File | 1990-06-16 | 15.4 KB | 521 lines

'   MENUFUN Written by: Robert R. Smith
'                       3812 Red Bud
'                       Imperial, MO  63052-1161
'                       CIS 72447,2643
'
'
'     Memory Moves with QB  by David Cleary
'     The QBNews  Volume  1, Number  1   November  1, 1989
'
'  I down loaded both from GENIE in MICROSOFT Libary
'
'   screen save and restore changed by me to use QBX STRINGASSIGN
'   changed to popup menuwindow with screen save and restore
'
'   MENUWIND By:        Raymond E Dixon
'                       5815 Buckley Dr.
'                       Jacksonville, Fl. 32244
'
'                       [phone]
'                       [phone]
'
'           Microsoft BASIC 7.0, Professional Development System
'              Copyright (C) 1987-1989, Microsoft Corporation
'
'           Microsoft QBX 7.0, Professional Development System
'              Copyright (C) 1987-1989, Microsoft Corporation
'
'    I would like to thank Microsoft for a great Program and
'    anyone serious about basic should consider (PDS) it,s
'    worth the upgrade.
'
'      I think the only routine that won't work with QB45 is
'      STRINGASSIGN  (load QBX with /l to load QBX.QLB)
'      which is a QBX function , replace with ALIAS "B$ASSN" for QB45.
'      these routines will work with QBX or BC command line.
'        (remember STRINGASSIGN is a memory move)
'
'      Buffer(1 to 2000) = 4000 bytes for screen'  2 bytes per integer
'      buffer = 8000 = 4 screens etc.
'      screens saved can be restored as many times as nessary
'      see subs scrnsave and restore for use of stringassign
'
'     CALL STRINGASSIGN(FromSeg, FromOfs, NumBytes, ToSeg, ToOfs, NumBytes)
'
'      with all the window programs around why write this, simple I write
'      small programs and need menus and windows with out loading
'      hundreds of routines I don't need and save thousands of bytes.
'      besides it's fun and I learn a lot from the exercize.
'
'      I remember the days when basic was fun and free now everybody
'      want's to make a buck, lets see some free code out there.
'
'
DECLARE SUB SCRREST (Buffer%(), ScnNo%)
DECLARE SUB SCRSAVE (Buffer%(), ScnNo%)
DECLARE SUB MenuArray (I%, length%, MenuStr$, Delimiters$, option$())
DECLARE SUB sglbox (leftcol%, toprow%, endcol%, endrow%)
DECLARE FUNCTION MenuWindow% (row%, col%, MenuStr$, Title$, MenuFore%, MenuBack%, Reversed%)
DECLARE FUNCTION str2token$ (Srce$, DELIM$)
DECLARE SUB dblbox (Title$, leftcol%, toprow%, endcol%, endrow%)
DECLARE SUB WaitKey ()

DEFINT A-Z

'Define Constants

CONST True = 1
CONST False = NOT True

CONST Black = 0
CONST Blue = 1
CONST Green = 2
CONST Cyan = 3
CONST Red = 4
CONST Magenta = 5
CONST Brown = 6
CONST White = 7
CONST Bright = 8
CONST Blink = 16
CONST Yellow = Brown + Bright

'Define Data Types

TYPE MenuData
   WordStart  AS INTEGER
   WordLen    AS INTEGER
   MenuLetter AS STRING * 1
   MenuWord   AS STRING * 40
END TYPE

'Declare Functions

   'menu option

   DIM option$(20)

'buffer for holding 2 screens , 4000 * 2 bytes for Integer = 8000 bytes total

   DIM Buffer(1 TO 4000)  '2000 integers = 4000 bytes for screen

KEY OFF
COLOR White, Blue
CLS

'Main loop

FOR I = 1 TO 25
LOCATE I, 1
PRINT STRING$(80, 176);
NEXT
     a$ = " Menu Windows By: Raymond E Dixon "
  LOCATE 5, (80 - LEN(a$)) / 2
  PRINT a$;
     a$ = " 5815 Buckley Dr. Jacksonville, Fl 32244 "
  LOCATE 23, (80 - LEN(a$)) / 2
  PRINT a$;

leftcol = 1: toprow = 1: endcol = 80: endrow = 25
CALL sglbox(leftcol, toprow, endcol, endrow)


DO

   LOCATE , , 0

           'menu$ maybe one string seperated by a , for each selection

           menu$ = "A - Select Type,"
   menu$ = menu$ + "B - Update - Search Parts,"
   menu$ = menu$ + "C - Print Parts List,"
   menu$ = menu$ + "D - Color,"
   menu$ = menu$ + "E - Exit to Dos"

   Title$ = "Main Menu" ' title$ maybe null ""

     'if row or column <= 1 then menu is centered on screen
     'if col is to large to fit then is adjusted
     'if row is to large to fit then is adjusted

   menuitem = MenuWindow%(0, 0, menu$, Title$, Black, White, Red)' + Bright)

   'a case for each menu item
   SELECT CASE menuitem
      CASE 1 'menu item 1

         Title$ = "Select Menu"
         menu$ = "Color/TV,BW/TV,STEREO,VCR,PROJECTION/TV"
         menuitem = MenuWindow%(0, 50, menu$, Title$, Black, White, Red)' + Bright)

         a$ = "You selected " + option$(menuitem)
         LOCATE 18, (80 - LEN(a$)) / 2
         PRINT a$;

         WaitKey

      CASE 2  'menu item

         a$ = "You selected " + option$(menuitem)
         LOCATE 18, (80 - LEN(a$)) / 2
         PRINT a$;

         WaitKey

      CASE 3  'menu item

         a$ = "You selected " + option$(menuitem)
         LOCATE 18, (80 - LEN(a$)) / 2
         PRINT a$;

         WaitKey

      CASE 4  'menu item

         a$ = "You selected " + option$(menuitem)
         LOCATE 18, (80 - LEN(a$)) / 2
         PRINT a$;

         WaitKey

      CASE ELSE   'Exit loop
         QuitFlag% = True

   END SELECT
   CALL SCRREST(Buffer(), 1)

LOOP UNTIL QuitFlag%

'Terminate Program

COLOR White, Blue
CLS

END

'
  SUB dblbox (Title$, leftcol, toprow, endcol, endrow)
' call routine
'    leftcol = 1: toprow = 1: endcol = 80: endrow = 23
'    leftcol = 1: toprow = 1: endcol = 80: endrow = 23

'    call dblbox(title$,leftcol,toprow,endcol,endrow)
'Qdblbox
      LOCATE toprow, leftcol
'draw drawpos of box
      PRINT CHR$(201);

      FOR drawpos = (leftcol + 1) TO (endcol - 1)
         PRINT CHR$(205);
      NEXT drawpos

      PRINT CHR$(187)
'draw side of box
      FOR drawpos = (toprow + 1) TO (endrow - 1)
         LOCATE drawpos, leftcol
         PRINT CHR$(186);
         LOCATE drawpos, endcol
         PRINT CHR$(186);
      NEXT drawpos
'draw bottom of box
      LOCATE endrow, leftcol
      PRINT CHR$(200);
      FOR drawpos = (leftcol + 1) TO (endcol - 1)
         PRINT CHR$(205);
      NEXT drawpos

      PRINT CHR$(188);

            tx$ = RTRIM$(Title$)
            IF LEN(tx$) > 0 THEN

                length = endcol - leftcol
                IF (LEN(tx$) + 2) < length THEN
                    LOCATE toprow, leftcol + INT(length / 2 - LEN(tx$) / 2) - 1
                    PRINT " "; tx$; " ";
                ELSE
                    LOCATE toprow - 1, leftcol
                    PRINT LEFT$(" " + tx$ + " ", (endcol - leftcol + 1))
                END IF

            END IF

   END SUB

SUB MenuArray (I, length, MenuStr$, Delimiters$, option$())

' Invoke str2token$ with the string to tokenize.

Array$ = str2token$(MenuStr$, Delimiters$)
 I = 0
length = 0

DO
   I = I + 1
   option$(I) = Array$

   'get max option length for display

   IF LEN(option$(I)) > length THEN
   length = LEN(option$(I))
   END IF

   ' Call str2token$ with a null string so it knows this
   ' isn't the first call.

   Array$ = str2token$("", Delimiters$)

LOOP WHILE Array$ <> ""


END SUB

'
'    menuwindow saves and restores screen
'
' Title$ = "Title"  maybe null ""
' Menu$ = "A-menu1,B-menu2,3-menu3,Menu4"
'          first letter must be different and Caps or Num
'
'     if row  <= 1 then menu is centered on screen vert
'     if column <= 1 then menu is centered on screen horiz
'     if col is to large to fit then is adjusted
'     if row is to large to fit then is adjusted
'     if row and col = 0 then menu is centered on screen
'
'
FUNCTION MenuWindow% (row%, col%, MenuStr$, Title$, MenuFore%, MenuBack%, Reversed%)
   SHARED Buffer()
   col% = col% + 1
   DIM Selection(1 TO 20) AS MenuData   '20 assumed to be the maximum selections
   COLOR MenuFore%, MenuBack%
   SHARED option$()

   CALL SCRSAVE(Buffer(), 1)
' Set up the menuitems.

    CALL MenuArray(I, length, MenuStr$, ",", option$())

    MenuChar% = 0

    'adjust col to fit
    IF col% > 80 - length THEN
    col% = (80 - length)
    END IF
    'adjust row to fit
    IF row% > 23 - I THEN
    row% = (24 - I)
    END IF

    'if column <= 1 then window is centered
    IF col% <= 1 THEN
    col% = (80 - length) / 2
    END IF
    'if row  <= 1 then window is centered
    IF row% <= 1 THEN
    row% = (24 - I) / 2
    END IF

    FOR j = 1 TO I

    LOCATE row% + j, col%
    PRINT option$(j) + STRING$(length - LEN(option$(j)), " ");
    NEXT j

     leftcol = col% - 1: toprow = row%: endcol = col% + length: endrow = row% + j

      LOCATE toprow, leftcol
'draw drawpos of box
      PRINT CHR$(201) + STRING$(endcol - leftcol - 1, 205) + CHR$(187);
'draw side of box

      FOR drawpos = (toprow + 1) TO (endrow - 1)
         LOCATE drawpos, leftcol
         PRINT CHR$(186);
         LOCATE drawpos, endcol
         PRINT CHR$(186);
      NEXT drawpos

'draw bottom of box

      LOCATE endrow, leftcol
      PRINT CHR$(200) + STRING$(endcol - leftcol - 1, 205) + CHR$(188);

            tx$ = RTRIM$(Title$)
            IF LEN(tx$) > 0 THEN

                lgth = endcol - leftcol
                IF (LEN(tx$) + 2) < lgth THEN
                    LOCATE toprow, leftcol + INT(lgth / 2 - LEN(tx$) / 2)
                    PRINT "["; tx$; "]";
                ELSE
                    LOCATE toprow - 1, leftcol - 1
                    PRINT LEFT$("|" + tx$ + "|", (endcol - leftcol + 3))
                END IF

            END IF

   FOR MenuChar% = row% + 1 TO row% + I'  Starts loop to test characters in menu
      Test% = SCREEN(MenuChar%, col%)

      SELECT CASE Test%
        CASE 64 TO 91, 47 TO 58  'Test to see if Character is between A and Z
         MenuNum = MenuNum + 1
         Selection(MenuNum).WordStart% = MenuChar%                       'Sets first column position in table for MenuWord and MenuLetter
         Selection(MenuNum).MenuLetter = CHR$(Test%)                     'Sets the letter to use for menu selection
         Selection(MenuNum).MenuWord = CHR$(Test%)                       'Puts whole word in table
         Selection(MenuNum).WordLen% = 1                                 'gives the selection a starting lenth of one
         CharString$ = CHR$(Test%)                                       'Sets first character of Character string

         'If not a space then add to Character string

        CASE IS <> 32
         CharString$ = CharString$ + CHR$(Test%)                         'adds to string
         Selection(MenuNum).MenuWord = CharString$                       'puts string in table
         Selection(MenuNum).WordLen% = Selection(MenuNum).WordLen% + 1   'adjust word length in table
      END SELECT

   NEXT MenuChar%
   MenuNum = 1
   DO
      COLOR , MenuBack%
      FOR MenuChar% = 1 TO 20                            '

      IF Selection(MenuChar%).WordStart% > 0 THEN

            COLOR Reversed%                              '
            LOCATE Selection(MenuChar%).WordStart, col%
                                                         'Runs through table to highlight
            PRINT Selection(MenuChar%).MenuLetter;        'first Capital letter of each
            LastSelection% = MenuChar%                   'menu selection
         ELSE                                            '
            MenuChar% = 20                               '
         END IF                                          '
      NEXT MenuChar%                                     '

      LOCATE Selection(MenuNum).WordStart, col%
      COLOR White + Bright, Reversed%                    'Bright white will always be Highlighted foreground

      'Print selection in highlight colors
      PRINT RTRIM$(option$(MenuNum)) + STRING$(length - LEN(option$(MenuNum)), " ");

      DO
         Response$ = UCASE$(INKEY$)                      'Get key response
         SELECT CASE Response$
            CASE CHR$(0) + CHR$(72)                      'Left Cursor
               GOSUB ResetSelection
               MenuNum = MenuNum - 1                     'Decrement 1 in menu
               IF MenuNum < 1 THEN
                  MenuNum = LastSelection%
               END IF
            CASE CHR$(0) + CHR$(80)                      'Right Cursor
               GOSUB ResetSelection
               MenuNum = MenuNum + 1                     'Increment 1 in menu
               IF MenuNum > LastSelection% THEN
                  MenuNum = 1
               END IF
            CASE CHR$(13)                                'Carriage Return - Make selection
               MenuWindow% = MenuNum
            CASE "A" TO "Z", "0" TO "9"                             'Capital Letter - Speed Selection
               FOR Compare% = 1 TO 20
                  IF Response$ = Selection(Compare%).MenuLetter THEN
                     MenuNum = Compare%
                     MenuWindow% = MenuNum
                     Response$ = CHR$(13)
                  END IF
               NEXT Compare%
            CASE ELSE
               'Fall through case                        'Anything else - forget it
         END SELECT
      LOOP UNTIL Response$ <> ""
   LOOP UNTIL Response$ = CHR$(13)                       'Exit loop if Carriage Return

   CALL SCRREST(Buffer(), 1)

   EXIT FUNCTION

ResetSelection:
   LOCATE row%, col%                               'This subroutine resets
   COLOR MenuFore%, MenuBack%                      'the current highlighted

   LOCATE Selection(MenuNum).WordStart, col%       'selection of the menubar to it's original color,
   PRINT RTRIM$(option$(MenuNum)) + STRING$(length - LEN(option$(MenuNum)), " ");

   COLOR Reversed%

   LOCATE Selection(MenuNum).WordStart, col%
   PRINT Selection(MenuNum).MenuLetter;

   RETURN

END FUNCTION

'
'    leftcol = 1: toprow = 1: endcol = 80: endrow = 23
'
SUB sglbox (leftcol, toprow, endcol, endrow)
      LOCATE toprow, leftcol
'top
      PRINT CHR$(218);
      FOR I = (leftcol + 1) TO (endcol - 1)
         PRINT CHR$(196);
      NEXT I
      PRINT CHR$(191)
'sides
      FOR I = (toprow + 1) TO (endrow - 1)
         LOCATE I, leftcol
         PRINT CHR$(179);
         LOCATE I, endcol
         PRINT CHR$(179);
      NEXT I
'bottom
      LOCATE endrow, leftcol
      PRINT CHR$(192);
      FOR I = (leftcol + 1) TO (endcol - 1)
         PRINT CHR$(196);
      NEXT I
      PRINT CHR$(217);
   END SUB

DEFSNG A-Z
FUNCTION str2token$ (Srce$, DELIM$)
STATIC Start%, SaveStr$


   ' If first call, make a copy of the string.
   IF Srce$ <> "" THEN
      Start% = 1: SaveStr$ = Srce$
   END IF

   BegPos% = Start%: Ln% = LEN(SaveStr$)
   ' Look for start of a token (character that isn't delimiter).
   WHILE BegPos% <= Ln% AND INSTR(DELIM$, MID$(SaveStr$, BegPos%, 1)) <> 0
      BegPos% = BegPos% + 1
   WEND
   ' Test for token start found.
   IF BegPos% > Ln% THEN
      str2token$ = "": EXIT FUNCTION
   END IF
   ' Find the end of the token.
   EndPos% = BegPos%
   WHILE EndPos% <= Ln% AND INSTR(DELIM$, MID$(SaveStr$, EndPos%, 1)) = 0
      EndPos% = EndPos% + 1
   WEND
   str2token$ = MID$(SaveStr$, BegPos%, EndPos% - BegPos%)
   ' Set starting point for search for next token.
   Start% = EndPos%

END FUNCTION

SUB WaitKey

   a$ = "Press any key to continue"
         LOCATE 19, (80 - LEN(a$)) / 2
         PRINT a$;

   DO
      Key$ = INKEY$
   LOOP UNTIL Key$ <> ""

END SUB