'===========================================================================
' Subject: Menu development system            Date: 09-15-02 (  :  )       
'  Author: Scott/Buffington/Decker            Code: PB                     
'  Origin: royscott@royscott.net            Packet: MENU.ABC
'===========================================================================
'MSD Project version 3 beta 2 (Menu System Development)
'***************************************************
'COPYWRITE: ROY SCOTT & ASSOCIATES 2002
'AUTHORS: Roy Scott, Fred Buffington, Walt Decker
'LICENSE: OPEN SOURCE FREEWARE
'  You may use this in your programs, make it a part of
'a compiled commercial product, and alter it to suit your
'purposes.
'  You may not, without the permission of the authors,
'distribute it for sale, make it a part of a distributed
'code collection for sale or in any way charge a fee for it.
'  It is not legal to use this product without this
'copyright header remaining intact. The authors assume no
'liability of any kind for the use of this product. It is
'up to the user to determine usability, fitness of purpose
'and correct operation.
'  To insure an uncorrupted product and be sure of getting
'the latest version, it is reccommended that you download
'it from: http://www.allbasiccode.com/.
'***************************************************
'All documentation for this product is in internal remarks

%test = 1  '0=library, 1=testing

#DIM ALL   'uncomment during testing

TYPE Umenu                 'type for dropdown menus; it is
                           'dimensioned in InitMenu to
                           'the # MainMenu headings
  NumItems      AS BYTE
  Row(1 TO 10)  AS BYTE
  Col(1 TO 10)  AS BYTE
  MENU(1 TO 10) AS STRING * 12
END TYPE

TYPE MenuMain              'type for main menu
  NumItems      AS BYTE    'Number of main menu headings
  Row(1 TO 10)  AS BYTE    'beginning row
  Col(1 TO 10)  AS BYTE    'beginning column
  MENU(1 TO 10) AS STRING * 8
END TYPE

TYPE Box                   'container for MSGBOX look and
                           'position.  Also used for menus
  ULChar AS STRING * 1     'upper left corner
  URChar AS STRING * 1     'upper right corner
  LLChar AS STRING * 1     'lower left
  LRChar AS STRING * 1     'lower right
  HZChar AS STRING * 1     'horizontal
  VTChar AS STRING * 1     'vertical
  OKbutn AS STRING * 6     'button strings
  Nobutn AS STRING * 6
  ScrnX  AS BYTE           'screen size = CONSOLE SCREEN size
  ScrnY  AS BYTE
  BoxTyp AS BYTE           'BoxType, 0 = no button, 1 = OK button
                           '2 = YES/NO buttons, 3 = inputbox +
                           ' OK/CANCEL buttons
  Uly    AS BYTE           'upper left corner of box
  Ulx    AS BYTE
  FGColr AS BYTE           'forground color for msgbox
  BGColr AS BYTE           'background color for msgbox
  MuFclr AS BYTE           'forground color for menu
  MuBclr AS BYTE           'background color for menu
  MuHFcl AS BYTE           'forground highlight color for menu
  MuHBcl AS BYTE           'background highlight color for menu
END TYPE

TYPE BUTTON                'type for buttons
  Iny   AS BYTE            'input box location
  Inx   AS BYTE
  Oky   AS BYTE            'OK button location
  Okx   AS BYTE
  Noy   AS BYTE            'No/Cancel button location
  Nox   AS BYTE
  FOCUS AS BYTE            'button/input box focus
END TYPE
GLOBAL MessBox AS Box        'Container for menu and message
                             ' box characters
GLOBAL DoubleClick AS BYTE   'Define # of button clicks
                             'if set requires double click
SUB InitMenu(Mitems() AS Umenu, bitems AS MenuMain)
'******************************************************************
'this sub contains all of the modifyable data elements in one place
'each section is defined by a lable to make it easier to identify
'the sections. Samples define are for example only.
'******************************************************************
menubar:      'Main Menu
'Row  Col  - can be changed to match your look
DATA 1,   1
'menubar no. of items (# of dropdown menus)
DATA 4
'menubar items data
DATA " File"," Edit"," Seek"," Help"
Menu1_data:    'Dropdown 1
'Number of items in dropdown 1
DATA 6
'dropdown 1 items data
DATA " New", " Open", " Save"," Save As"," Email"," Exit"
Menu2_data:   'Dropdown 2
'number of items in dropdown 2
DATA 4
'dropdown 2 items data
DATA " Cut", " Copy", " Paste"," Delete"
Menu3_data:  'Dropdown 3
'number of items in dropdown 3
DATA 3
'dropdown 3 items data
DATA " Find", " Replace", " Again"
Menu4_data:  'Dropdown 4
'number of items in dropdown 4
DATA 2
'dropdown 4 items data
DATA " Help", " About"
LOCAL Number AS LONG       'Number of dropdowns
LOCAL accum AS LONG        'counters
LOCAL I AS LONG, J AS LONG '    |
LOCAL K AS LONG, L AS LONG '    |
LOCAL M AS LONG, N AS LONG '    |
MessBox.ULChar = CHR$(201)  ' UPPER LEFT CORNER
MessBox.URChar = CHR$(187)  ' UPPER RIGHT CORNER
MessBox.LLChar = CHR$(200)  ' LOWER LEFT CORNER
MessBox.LRChar = CHR$(188)  ' LOWER RIGHT CORNER
MessBox.HZChar = CHR$(205)  ' HORIZONTAL
MessBox.VTChar = CHR$(186)  ' VERTICAL
MessBox.ScrnY  = 28         ' NUMBER OF SCREEN ROWS
MessBox.ScrnX  = 80         ' NUMBER OF SCREEN COLUMNS
' ********* Dropdowm COLORS ************
MessBox.MuFclr = 15    ' Normal Menu Char Color
MessBox.MuBclr =  9    ' Normal Menu Char Background color
MessBox.MuHFcl = 14    ' Highlight Menu Char Color
MessBox.MuHBcl =  4    ' Highlight Menu Char Background color
'********** Beginning of Executable code *************
  Bitems.Row(1) = VAL(READ$(1)) 'Row for MenuBar
  Bitems.Col(1) = VAL(READ$(2)) 'Col for MenuBar
  Number = VAL(READ$(3))    '# of bar items (dropdown menus)
  Bitems.NumItems = Number
  accum = 4      'Set to # of bar items
  FOR M = 1 TO Number      'bar item load loop
    bitems.Menu(M) = READ$(accum)    'get data into array
    '********* Change the following for a different look *********
    IF M > 1 THEN     'calculate column for next print
      Bitems.Row(M) = Bitems.Row(1)
      Bitems.Col(M) = Bitems.Col(M - 1) + LEN(Bitems.Menu(M))
    END IF
    INCR Accum    'step data position
  NEXT M          'next bar data item
  REDIM Mitems(1 TO Number)    'an array of dropdown arrays
  I = accum   'first item data position
  L = 1       'inner loop seed
  FOR J = 1 TO Number   'outer loop all dropdowns (# items in menu bar)
    M = VAL(READ$(I))   '# of items in current dropdown menu
    Mitems(L).NumItems = M
    INCR I    'step data read position
    FOR K = 1 TO M 'read each dropdown item
      Mitems(L).MENU(K) = READ$(I)      'dropdown menu item
      '********* Change this for a different look ******************************
      Mitems(L).Col(K)  = Bitems.Col(J) 'start Column of menu item (X)
      Mitems(L).Row(K)  = BitEms.Row(J) + K  'start Row or menu item (Y)
      INCR I  'step data position
    NEXT K    'next dropdown item
    INCR L    'step dropdown position
  NEXT J      'next dropdown menu
END SUB

FUNCTION KeyPress(Lmx AS LONG, Lmy AS LONG, Lbutton AS LONG) AS LONG
'*******************************************
' Gets key press and/or mouse events
' Lmx = Row of Mouse cursor
' Lmy = Column of Mouse cursor
' Lbutton = button pressed
'*******************************************
LOCAL Key AS STRING         'string returned by WAITKEY$
LOCAL LenKey AS LONG        'length of Key
  Lbutton = 0                 'zero out Lbutton
  Key = WAITKEY$              'wait for event
  LenKey = LEN(Key)
  SELECT CASE LenKey   'decide if keyboard or mouse event
    CASE 1                'keyboard event
      KeyPress = ASC(Key)
    CASE 2                'Keyboard event
      KeyPress = -ASC(Key, 2)
    CASE 4                'Mouse Event
      IF ISTRUE DoubleClick THEN  '2 clicks (DoubleClick > 0)
        IF ASC(Key, 3) = 2 THEN Lbutton = ASC(Key, 4)
      ELSE                '1 click (DoubleClick = 0)
        IF ASC(Key, 3) = 4 THEN Lbutton = ASC(Key, 4)
      END IF
      Lmx = MOUSEX
      Lmy = MOUSEY
      KeyPress = 32767    'indicate mouse event
  END SELECT
END FUNCTION

SUB ColorWords(Y AS LONG, X AS LONG, Fcolor AS INTEGER, _
               Bcolor AS INTEGER, sWord AS STRING)
'**********************************************
' General purpose routine changes foreground and background
' character colors at Row, Column
' Fcolor = forground color
' Bcolor = background color
' sWord = string to display
'**********************************************
  LOCATE Y, X
  COLOR Fcolor, Bcolor
  PRINT sWord;
END SUB

FUNCTION FNMenu(Items AS Umenu) AS LONG
'*******************************************
' returns the number of the item selected
' Items structure should be dimensioned 1 TO NumberOfItems
' in dropdown
' This handles type 0 message boxes, ie, dropdown menus.
' With appropriate code, MSGBOX could handle this.
'*******************************************
LOCAL NumItems AS INTEGER  'Number of items in structure
LOCAL I AS INTEGER         'Counter
LOCAL Key    AS LONG       'Key code
LOCAL MenuSize    AS LONG
LOCAL LastItem    AS LONG  'Place holder
LOCAL Row         AS LONG  'Current row
LOCAL Col         AS LONG  'Current column
LOCAL MenuTop     AS LONG  'first item in menu
LOCAL Menu1()     AS STRING  'temporay array
LOCAL tBox AS Box            'box structure
LOCAL RodentX AS LONG    'Mouse Cursor Column
LOCAL RodentY AS LONG    'Mouse Cursor Row
LOCAL RodentB AS LONG    'Mouse Button
LOCAL MaxRow  AS LONG    'Bottom of menu
LOCAL MaxCol  AS LONG    'Left side of menu
LOCAL NFcolor AS INTEGER, NBcolor AS INTEGER
LOCAL HFcolor AS INTEGER, HBcolor AS INTEGER
  NFcolor = MessBox.MuFclr   'Normal Dropdown FGcolor
  NBcolor = MessBox.MuBclr   '  ""      ""    BGcolor
  HFcolor = MessBox.MuHFcl   'Hilighted dropdown FGcolor
  HBcolor = MessBox.MuHBcl   '   ""        ""    BGcolor
  tBox = MessBox       'initialize local structure
  LastItem = 1         'First item in menu
  NumItems = Items.NumItems   '# defined in InitMenu
  DIM Menu1(1 TO NumItems)    'dropdown menu outline array
  Row = Items.Row(1)          'Defined in InitMenu
  Col = Items.Col(1)
  tBox.ULx = Col
  tBox.ULy = Row
  tbox.FGColr = MessBox.MuFclr   'set dropdown FGcolor
  tbox.BGColr = MessBox.MuBclr   ' "     "     BGcolor
  FOR I = 1 TO NumItems   'create string array
    Menu1(I) = Items.menu(I)
  NEXT I
  CALL DrawBox(Menu1(), tBox)  'draw dropdown
  ERASE Menu1              'release memory
  Show_Items: '
  MenuTop = tBox.ULy 'calculated in DrawBox
  Col = tBox.ULx
  Row = tBox.ULy     'MenuTop
  MaxRow = Row + NumItems - 1   'Row of bottom menu item
  MaxCol = Items.Col(1) + LEN(Items.Menu(1)) - 1  'Right side of menu
HiLite_Item: '
  CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(LastItem))
FNKey: '*** Find out what the user is doing
  Key = KeyPress(RodentX, RodentY, RodentB)
  IF Key > 255 THEN    'check for mouse event
    IF RodentB THEN    'mouse button press
      ' Close menu
      IF (RodentY < MenuTop) OR (RodentY > MaxRow) THEN EXIT FUNCTION
      IF (RodentX < Col) OR (RodentX > MaxCol) THEN EXIT FUNCTION
    ELSE   'no action - mouse outside of menu area
      IF (RodentY < MenuTop) OR (RodentY > MaxRow) THEN GOTO FNKey
      IF (RodentX < Col) OR (RodentX > MaxCol) THEN GOTO FNKey
    END IF
    FOR I = 1 TO NumItems   'Track mouse while in menu area
      IF RodentY = Items.Row(I) + 1 THEN
        ' Make color normal
        CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                      BYCOPY Items.Menu(LastItem))
        LastItem = I
        Row = Items.Row(I) + 1
        ' Highlight text
        CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(LastItem))
        IF RodentB THEN     'check button again
          FNMenu = LastItem
          EXIT FUNCTION
        END IF
      END IF
    NEXT I
    GOTO FNKey
  END IF
  IF (Key = -80) OR (key = 9) THEN  'down arrow or tab
    IF LastItem >= NumItems THEN
      CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                    BYCOPY Items.Menu(LastItem))
      LastItem = 1
      Row = MenuTop
      GOTO HiLite_Item
    END IF
    CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                  BYCOPY Items.Menu(LastItem))
    INCR LastItem
    INCR Row
    GOTO HiLite_Item
  END IF
  IF Key = -72 THEN               'up arrow
    IF LastItem <= 1 THEN
      CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                      BYCOPY Items.Menu(LastItem))
      LastItem = NumItems
      Row = Row + NumItems - 1
      GOTO HiLite_Item
    END IF
    CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                  BYCOPY Items.Menu(LastItem))
    DECR LastItem
    DECR Row
    GOTO HiLite_Item
  END IF
  IF (Key = -75) OR (Key = -77) THEN  'left or right arrow
    FNMenu = Key
    EXIT FUNCTION
  END IF
  IF (Key = 13) THEN         'ENTER key - item selected
    FNMenu = LastItem
    EXIT FUNCTION
  ELSEIF (Key = 27) THEN     'ESC key - abort selection
    FNMenu = 0
    EXIT FUNCTION
  ELSE
    GOTO FNKey
  END IF
END FUNCTION

FUNCTION DispMain(Items AS MenuMain,Cs AS INTEGER,Ms AS INTEGER) AS LONG
'*******************************************************************
'             Handles the main menu (menu bar)
' Items = headings in menu bar
' Cs = Current screen number
' Ms = Menu screen number
'*******************************************************************
STATIC sSize  AS LONG
LOCAL lSize   AS LONG
LOCAL lI AS LONG
LOCAL lastitem AS LONG
LOCAL row AS LONG
LOCAL col AS LONG
LOCAL key AS LONG
LOCAL fKey AS LONG        'Function Key calculation (F1 - F10)
LOCAL RodentX AS LONG     'Mouse Cursor Column
LOCAL RodentY AS LONG     'Mouse Cursor Row
LOCAL RodentB AS LONG     'Mouse Button
LOCAL MaxRow  AS LONG     'Bottom of Menu
LOCAL MaxCol  AS LONG     'Width of Menu
LOCAL NFcolor AS INTEGER  'Normal foreground
LOCAL NBcolor AS INTEGER  'Normal background
LOCAL HFcolor AS INTEGER  'High light foreground
LOCAL HBcolor AS INTEGER  'High light background
  NFcolor = MessBox.MuFclr
  NBcolor = MessBox.MuBclr
  HFcolor = MessBox.MuHFcl
  HBcolor = MessBox.MuHBcl
  fkey = -(59 + items.numitems)  'Function key Offset
  MaxRow = Items.Row(1)          'start of menu bar
  MaxCol = LEN(Items.Menu(1))    'size of bar item
Locate_Menu: ' Next 2 routines refresh the bar
  COLOR NFcolor, NBcolor
  LOCATE Items.Row(1), Items.Col(1)
  PRINT STRING$(80, " ");
show_items:
  FOR lI = 1 TO Items.NumItems
    LOCATE Items.row(lI), Items.Col(lI)
    PRINT Items.Menu(lI)
  NEXT lI
  PCOPY Cs, Ms                   'save it
  Row = Items.Row(1)             'first item
  Col = Items.Col(1)             'where the bar is
  lastitem = 1
HiLite_Item: ' Highlight the bar item
  CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(LastItem))
FNKey: '*** Find out what the user is doing
  Key = KeyPress(RodentX, RodentY, RodentB)
  'Check for mouse movement and left button press
  'If mouse status has changed, Key will = 32767
  IF Key > 255 THEN
    'If the mouse cursor is above or below the menu, no action will occur
    IF RodentY > MaxRow OR RodentY < Items.Row(1) THEN GOTO Con1
    'Check for column range
    FOR lI = 1 TO Items.NumItems
      IF (RodentX < Items.Col(lI)) OR (RodentX > Items.Col(lI) + MaxCol - 1) THEN
        GOTO Next_Item
      END IF
      'Make last menu item normal color
      CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(LastItem))
      Col = Items.Col(lI)
      LastItem = lI
      'Hilite new menu item
      CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(LastItem))
      IF RodentB THEN         'check for button press
        DispMain = LastItem
        EXIT FUNCTION
      END IF
      GOTO FNKey
Next_Item: '
    NEXT lI
  END IF
Con1: ' Check function key status
  IF (key < -58) AND (key > fkey) THEN
    CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(LastItem))
    LastItem = ABS(key) - 58
    Col = Items.Col(LastItem)
    CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(LastItem))
    dispmain = LastItem
    EXIT FUNCTION
  END IF
  IF (Key = -77) OR (key = 9) THEN  'Right arrow key or tab
    IF LastItem >= Items.NumItems THEN
      CALL ColorWords(Row, Col, NFcolor, NBcolor, _
                    BYCOPY Items.Menu(LastItem))
      LastItem = 1
      Col = Items.Col(LastItem)
      GOTO HiLite_Item
    END IF
    CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(LastItem))
    INCR LastItem
    Col = Items.Col(LastItem)
    GOTO HiLite_Item
  END IF
  IF Key = -75 THEN            'Left arrow key
    IF LastItem <= 1 THEN
      CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(LastItem))
      LastItem = Items.NumItems
      Col = Items.Col(LastItem)
      GOTO HiLite_Item
    END IF
    CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(LastItem))
    DECR LastItem
    Col = Items.Col(LastItem)
    GOTO HiLite_Item
  END IF
  IF (Key = 13) THEN          'menu selected
    dispmain = LastItem
    EXIT FUNCTION
  ELSEIF (key = 27) THEN      'no selection
    dispmain = 0
    EXIT FUNCTION
  ELSE
    GOTO FNKey
  END IF
END FUNCTION

FUNCTION MENU(Items AS MenuMain, Mnuitems() AS Umenu) AS LONG
'****************************************************
'        Controls dropdown menu selection
'****************************************************
LOCAL curscreen%,storescreen%,menuscreen%
STATIC MenuLoc() AS LONG    '*** Not Used
LOCAL lresult AS LONG       'Return valuse from functions called
LOCAL menuno AS LONG        ' ditto
STATIC MenuSize AS LONG
LOCAL Row AS LONG, Col AS LONG
LOCAL HFcolor AS INTEGER, HBcolor AS INTEGER
LOCAL NFcolor AS INTEGER, NBcolor AS INTEGER
LOCAL I AS LONG
  HFcolor = MessBox.MuHFcl
  HBcolor = MessBox.MuHBcl
  NFcolor = MessBox.MuFclr
  NBcolor = MessBox.MuBclr
  CurScreen% = 1
  StoreScreen% = 2
  MenuScreen% = 3
redo:
  IF ISFALSE MenuSize THEN
    REDIM MenuLoc(1 TO CurScreen%)
  END IF
  PCOPY CurScreen%, StoreScreen%
  '    Get menu bar selection
  lresult = DispMain(Items, CurScreen, MenuScreen)
  MenuSize = Items.NumItems   'Number of dropdown menus (from InitMenu)
  menuno = lresult            'Which item selected
Check_Result: '
'************************** SELECT DROPDOWM ITEM ******************
' The following loop will have to be modified if there are more than
' 8 menubar items or the return from FNMenu for TAB modified
' the use of more than 8 items is not reccommended as they will be
' past the edge of the displayed screen.
'******************************************************************
  FOR I = 1 TO MenuSize
    IF I = lresult THEN
      Row = Items.Row(I)
      Col = Items.Col(I)
      CALL ColorWords(Row, Col, HFcolor, HBcolor, BYCOPY Items.Menu(I))
      lresult = FNMenu(Mnuitems(I))
      EXIT FOR
    END IF
  NEXT I
  'Selection from FNMenu
  SELECT CASE lresult
    CASE -77, -75, 9      'left arrow, right arrow, tab
      PCOPY MenuScreen%, CurScreen%
      SELECT CASE lresult
        CASE -75          'left arrow
          DECR menuno
          IF menuno < 1 THEN menuno = MenuSize
          lresult = menuno
          Row = Items.Row(Menuno)
          Col = Items.Col(Menuno)
          CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(Menuno))
          GOTO Check_Result
        CASE -77,9        'right arrow, tab
          INCR menuno
          IF MenuNo > MenuSize THEN MenuNo = 1
          lresult = menuno
          CALL ColorWords(Row, Col, NFcolor, NBcolor, BYCOPY Items.Menu(Menuno))
          GOTO Check_Result
        CASE 0
          lresult = 0
      END SELECT
  END SELECT
  PAGE StoreScreen%, StoreScreen%
  PCOPY StoreScreen%, CurScreen%
  PAGE CurScreen%, CurScreen%
  IF lresult = 0 THEN
    MENU = 0
  ELSE
    MENU = lresult+(menuno*10)  '2 digit code for item in drop down
  END IF
END FUNCTION

SUB showbar(ems AS MenuMain)
LOCAL lI AS LONG
'************************* PRINT MENU BAR ***********************
  LOCATE ems.Row(1), ems.Col(1)
  COLOR MessBox.MuFclr, MessBox.MuBclr
  PRINT STRING$(80, " ");
  FOR lI = 1 TO ems.NumItems
    LOCATE ems.Row(lI), ems.Col(lI)
    PRINT ems.Menu(lI);
  NEXT lI
END SUB

FUNCTION MSGBOX(MesType AS LONG, Msg() AS STRING, fcolor AS INTEGER, _
     bcolor AS INTEGER, hcolor AS INTEGER,hbcolor AS INTEGER) AS LONG
'**************************************************************
' ARGUMENT LIST:
' MesType can be 0, 1, 2 or 3
'    0 = No buttons, no input box (dropdown menu)
'    1 = OK button only
'    2 = YES and NO buttons
'    3 = Input Box, OK button, Cancel button
'*** MesType 0 (dropdown menu) is handled in FNMenu
'
' Msg() can be up to 16 elements on a 25 row screen, and up to 77 characters
'    on an 80 column screen.  Msg() must be dimensioned 1 TO NumberOfElements
' If MesType = 3, the input is returned in Msg(1)
' 4 colors--fcolor=normal foreground bcolor=normal background
'           hcolor=hilite foreground hbcolor=hilite background
'for text hilite set hcolor to contrasting color and hbcolor=bcolor
'for background hilite set hcolor=fcolor and hbcolor to contrasting color
'msgbox returns a 2 digit number--1st number is message type
'                                 2nd number is chosen button
'************************************************************* **
LOCAL tBox AS Box, tButn AS BUTTON
LOCAL sYesButton AS STRING, sNoButton AS STRING
LOCAL sInputBox  AS STRING
LOCAL Xcurs AS LONG, YCurs AS LONG
LOCAL key AS LONG, lStrPos AS LONG
LOCAL curscreen AS INTEGER, storescreen AS INTEGER
LOCAL RodentX AS LONG       'Mouse Cursor Column
LOCAL RodentY AS LONG       'Mouse Cursor Row
LOCAL RodentB AS LONG       'Mouse Button
  curscreen% = 1
  storescreen% = 2
  PCOPY CurScreen%, StoreScreen%
  CURSOR OFF
  tBox = MessBox         'initialize
  tBox.BoxTyp = MesType
  tBox.FGcolr = fcolor
  tBox.BGcolr = bcolor
  CALL DrawBox(Msg(), tBox, tButn) 'draw message box
  SELECT CASE MesType
    CASE 1, 2
      sYesButton = TRIM$(tBox.OkButn) 'set up for toggling
      sNoButton = TRIM$(tBox.NoButn)  'highlight button focus
      CALL ColorWords(BYCOPY tButn.OKy, BYCOPY tButn.OKx, Hcolor, _
                    hbcolor, sYesButton)
    CASE 3
      sYesButton = TRIM$(tBox.OkButn)
      sNoButton = TRIM$(tBox.NoButn)
      sInputBox = STRING$(62, " ")
      'returned to normal colors for input box
      CALL ColorWords(BYCOPY tButn.INy, BYCOPY tButn.INx, Fcolor, _
                    bcolor, sInputBox)
      LOCATE tButn.INy, tButn.INx
      CURSOR ON, 20
      Xcurs = tButn.INx
      Ycurs = tButn.INy
  END SELECT
  sInputBox = ""     'container for input box entry
fnkey:
  Key = KeyPress(RodentX, RodentY, RodentB)
  SELECT CASE MesType
    CASE 1
      IF Key > 255 THEN     ' Check for mouse event
        IF (RodentY <> tButn.OKy) THEN GOTO fnkey  ' Not button row
        ' check for mouse in button
        IF (RodentX < tButn.OKx) OR _
          (RodentX > tButn.OKx + LEN(sYesButton) - 1) THEN GOTO fnKey
        IF RodentB THEN Key = 13  'mouse in button & left mouse button
                                  'pressed
      END IF
      'OR did not work below, had to change it to AND
      IF (Key <> 13) AND (Key <> 27) THEN GOTO fnkey
      MSGBOX = 11
      GOTO CleanUp
    CASE 2
      IF Key > 255 THEN     'Check for mouse event
        IF (RodentY <> tButn.OKy) THEN GOTO fnkey 'Not in button row
        ' check for which button
        Key = ABS((RodentX > tButn.OKx AND RodentX < tButn.Okx + _
                   LEN(sYesButton)) + 2 * (RodentX > tButn.Nox _
                   AND RodentX < tButn.NOx + LEN(sNoButton)))
        SELECT CASE Key
          CASE 1             ' in OK button
            IF RodentB THEN
              MSGBOX = 21
              GOTO CleanUp
            END IF
          CASE 2             ' in Cancel button
            IF RodentB THEN
              MSGBOX = 22
              GOTO CleanUp
            END IF
        END SELECT
        GOTO fnkey
      END IF
      'Key press events
      IF (Key = -77) OR (Key = -75) OR (Key = 9) THEN 'left arrow,
                                                      'right arrow,
                                                      'or tab
        IF tButn.Focus = 1 THEN       'switch button focus
          tButn.Focus = 2
          CALL ColorWords(BYCOPY tButn.OKy, BYCOPY tButn.OKx, fcolor, _
                        bcolor, sYesButton)
          CALL ColorWords(BYCOPY tButn.Noy, BYCOPY tButn.Nox, hcolor, _
                        hbcolor, sNoButton)
        ELSE
          tButn.Focus = 1
          CALL ColorWords(BYCOPY tButn.Noy, BYCOPY tButn.Nox, fcolor, _
                        bcolor, sNoButton)
          CALL ColorWords(BYCOPY tButn.Oky, BYCOPY tButn.OKx, hcolor, _
                        hbcolor, sYesButton)
        END IF
      END IF
      IF (Key = 13) THEN          'ENTER was pressed
        IF tButn.Focus = 1 THEN MSGBOX = 21
        IF tButn.Focus = 2 THEN MSGBOX = 22
        GOTO CleanUp
      END IF
    CASE 3
      SELECT CASE Key
        CASE > 255          'check for mouse event
                        'input box row      or     button row
          Key = ABS((RodentY = tButn.InY) + 2 * (RodentY = tButn.OkY))
          SELECT CASE Key
            CASE 1                   'in input box row
              IF (RodentX > tButn.InX) AND (RodentX < tButn.Inx + 62) THEN
                IF RodentB THEN      'in input box check mouse button
                                    'press
                  tButn.Focus = 1
                  LOCATE Ycurs, Xcurs
                  CURSOR ON, 20
                END IF
              END IF
              GOTO fnkey
            CASE 2                   'in button row
              'check if in OK or Cancle button
              Key = ABS((RodentX > tButn.OKx AND RodentX < tButn.Okx + _
                       LEN(sYesButton)) + 2 * (RodentX > tButn.Nox _
                       AND RodentX < tButn.NOx + LEN(sNoButton)))
              IF RodentB THEN
                IF Key = 1 THEN       'OK button
                  tButn.Focus = 2
                  Key = 13
                  GOTO Escape
                ELSEIF Key = 2 THEN   'Cancle button
                  tButn.Focus = 3
                  Key = 13
                  GOTO Escape
                END IF
                GOTO fnkey            'mouse button pressed but not
                                      'in OK or Cancel
              END IF
          END SELECT
        CASE -80, -15, 9    'down arrow, CTRL + TAB, tab
          CURSOR OFF        'toggle focus
          SELECT CASE tButn.Focus
            CASE 1
              tButn.Focus = 2
              CALL ColorWords(BYCOPY tButn.Oky, BYCOPY tButn.Okx, hcolor, _
                            hbcolor, sYesButton)
            CASE 2
              tButn.Focus = 3
              CALL ColorWords(BYCOPY tButn.Oky, BYCOPY tButn.Okx, fcolor, _
                            bcolor, sYesButton)
              CALL colorWords(BYCOPY tbutn.Noy, BYCOPY tbutn.Nox, hcolor, _
                            hbcolor, sNoButton)
            CASE 3
              tButn.Focus = 1
              CALL ColorWords(BYCOPY tButn.Noy, BYCOPY tButn.Nox, fcolor, _
                            bcolor, sNoButton)
              LOCATE Ycurs, Xcurs
              CURSOR ON, 20
          END SELECT
        CASE 13, 27      'ENTER, ESC
Escape: '
          'changed to return appropriate button code if these keys pressed
          'while in input box
          IF key = 13 THEN
            SELECT CASE tButn.Focus
              CASE 1,2
                Msg(1) = sInPutBox
                MSGBOX = 32
              CASE 3
                Msg(1) = ""
                Msgbox = 33
            END SELECT
          ELSE
            'input abandoned
            Msg(1) = ""
            Msgbox = 33
          END IF
          GOTO CleanUp
        CASE 8
          IF lStrPos < = 0 THEN
            lStrPos = 0
            GOTO FnKey
          END IF
          IF ISFALSE CURSOR THEN CURSOR ON, 20
          MID$(sInputBox, lStrPos, 1) = " "
          'changed colors for sInputBox to regular colors
          'this problem was introduced by my 4th color parameter
          CALL ColorWords(BYCOPY tButn.Iny, BYCOPY tButn.Inx, fColor, _
                        bcolor, sInputBox)
          sInputBox = RTRIM$(sInputBox)
          CALL ColorWords(BYCOPY tButn.Iny, BYCOPY tButn.Inx, fColor, _
                        bcolor, sInputBox)
          DECR lStrPos
          DECR Xcurs
      CASE > 31
        'do not allow run over on input box
        IF LEN(sInputBox) < 62 THEN
          IF ISFALSE CURSOR THEN CURSOR ON, 20
          sInputBox = sInputBox + CHR$(Key)
          CALL ColorWords(Ycurs, Xcurs, fColor, bcolor, CHR$(Key))
          INCR Xcurs
          INCR lStrPos
        END IF
    END SELECT
  END SELECT
  GOTO FnKey
cleanup:
  CURSOR ON,20
  PAGE StoreScreen%, StoreScreen%
  PCOPY StoreScreen%, CurScreen%
  PAGE CurScreen%, CurScreen%
END FUNCTION

SUB DrawBox(sText() AS STRING, typBox AS Box, OPT typB AS BUTTON)
'**************** DISPLAYS DROPDOWN MENUS AND MESSAGE BOXES ***********
'DRAWS:
'      type 0 = dropdown menu
'      type 1 = 1 button
'      type 2 = 2 button (YES and NO)
'      type 3 = input box + 2 buttons (OK and CANCEL)
'INPUTS:
'      sText() = array to display in box
'      typBox  = UDT with display info
'      typB    = Optional UDT with button info

'POSSIBLE INHANCEMENTS: add code to display default text in input box
'************************************************************************
LOCAL lMaxLen AS LONG, NumStrs    AS LONG
LOCAL I       AS LONG, OldNumStr  AS LONG
LOCAL Y       AS LONG, CBy        AS LONG
LOCAL CBx     AS LONG
LOCAL sYesButn AS STRING, sNoButn AS STRING
LOCAL s_Top    AS STRING, sBottom AS STRING
LOCAL sTemp    AS STRING
LOCAL typBut AS BUTTON
  NumStrs = UBOUND(sText)
  OldNumStr = NumStrs
  FOR I = 1 TO NumStrs
    Y = LEN(sText(I))
    lMaxLen = MAX&(Y, lMaxLen)
  NEXT I
  CBy = typBox.ScrnY \ 2    'Find center of screen
  CBx = typBox.ScrnX \ 2
  '*** type zero (dropdown menu) falls through this ***
  SELECT CASE typBox.BoxTyp
    CASE 1, 2, 3
      typBox.Ulx = CBx - lMaxLen \ 2 - 1  'upper left corner
      SELECT CASE typBox.BoxTyp
        CASE 1
          'pad labels with chr 255 to length desired to max of 6 char
          sYesButn = STRING$(2,255)+"OK"+STRING$(2,255)
          typBox.OkButn = sYesButn
          NumStrs = NumStrs + 4
          typBox.Uly = CBy - (NumStrs + 1) \ 2
          REDIM PRESERVE sText(1 TO NumStrs)
        CASE 2
          sYesButn = STRING$(1,255)+"YES"+STRING$(2,255)
          sNoButn =  STRING$(2,255)+"NO"+STRING$(2,255)
          typBox.OkButn = sYesButn
          typBox.NoButn = sNoButn
          NumStrs = NumStrs + 4
          typBox.Uly = CBy - (NumStrs + 1) \ 2
          REDIM PRESERVE sText(1 TO NumStrs)
        CASE 3
          sYesButn = STRING$(2,255)+"OK"+STRING$(2,255)
          sNoButn =  "Cancel"
          typBox.OkButn = sYesButn
          typBox.NoButn = sNoButn
          NumStrs = NumStrs + 7
          IF lMaxLen < 68 THEN lMaxLen = 68
          typBox.Uly = CBy - (NumStrs + 1) \ 2
          typBox.Ulx = CBx - lMaxLen \ 2 - 1
          REDIM PRESERVE sText(1 TO NumStrs)
      END SELECT
  END SELECT
  'Draw the box and fill it with text
  s_Top = typBox.UlChar + STRING$(lMaxLen ,typBox.HZChar) + typBox.URChar
  lMaxLen = LEN(s_Top) - 2
  COLOR typBox.FGcolr, typBox.BGcolr
  LOCATE typBox.Uly, typBox.Ulx
  PRINT s_Top
  Y = typBox.Uly + 1
  FOR I = 1 TO NumStrs
    sTemp = sText(I) + STRING$(lMaxLen - LEN(sText(I)), " ")
    sTemp = typBox.VTChar + sTemp + typBox.VTChar
    LOCATE Y, typBox.Ulx
    PRINT sTemp
    INCR Y
  NEXT I
  sBottom = typBox.LLChar + STRING$(lMaxLen, typBox.HZChar) + typBox.LRChar
  LOCATE Y, typBox.Ulx
  PRINT sBottom
  typBox.ULx = typBox.ULx + 1   'set to inside of box
  typBox.ULy = typBox.ULy + 1
  '*** Build the buttons; dropdowns fall through this ****
  SELECT CASE typBox.BoxTyp
    CASE 1, 2
      Y = Y - 3
      typBut.Focus = 1
      SELECT CASE typBox.BoxTyp
        CASE 1                   ' button
          lMaxLen = LEN(sYesButn) + 2    'find center & set left side of
                                         'button
          typBut.OKy = Y + 1             'inside button
          typBut.OKx = CBx - lMaxLen \ 2 - 1  'left side of button
          LOCATE Y, typBut.OKx
          s_Top = typBox.UlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                                        typBox.URChar
          sBottom = typBox.LlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                                          typBox.LRChar
          PRINT s_Top
          sTemp = typBox.VTChar + sYesButn + typBox.VTChar 'middle
          LOCATE Y + 1, typBut.OKx
          PRINT sTemp
          LOCATE Y + 2, typBut.OKx
          PRINT sBottom
          typBut.OKx = typBut.OKx + 1                      'inside of button
        CASE 2         '2 buttons; spreads them from center of box
OK_Cancel: '
          lMaxLen = LEN(sYesButn) + 2
          typBut.OKy = Y + 1
          typBut.OKx = CBx - lMaxLen - 2
          typBut.Noy = typBut.OKy
          typBut.Nox = CBx + 2
          s_Top = typBox.UlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                                        typBox.URChar
          sBottom = typBox.LlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                                        typBox.LRChar
          sTemp = typBox.VTChar + sYesButn + typBox.VTChar
          LOCATE Y, typBut.OKx
          PRINT s_Top
          LOCATE Y + 1, typBut.OKx
          PRINT sTemp
          LOCATE Y + 2, typBut.OKx
          PRINT sBottom
          lMaxLen = LEN(sNoButn) + 2
          s_Top = typBox.UlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                typBox.URChar
          sBottom = typBox.LlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
                typBox.LRChar
          sTemp = typBox.VTChar + sNoButn + typBox.VTChar
          LOCATE Y, typBut.Nox
          PRINT s_Top
          LOCATE Y + 1, typBut.Nox
          PRINT sTemp
          LOCATE Y + 2, typBut.Nox
          PRINT sBottom
          typBut.OKx = typBut.OKx + 1
          typBut.Nox = typBut.Nox + 1
      END SELECT
    CASE 3          'builds input box
      Y = Y - 6     'location of input box top
      lMaxLen = 64
      s_Top = typBox.UlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
              typBox.URChar
      sBottom = typBox.LlChar + STRING$(lMaxLen - 2, typBox.HZChar) + _
            typBox.LRChar
      sTemp = typBox.VTChar + STRING$(lMaxLen - 2, " ") + typBox.VTChar
            typBut.Iny = Y + 1
      typBut.Inx = CBx - lMaxLen \ 2
      LOCATE Y, typBut.Inx
      PRINT s_top
      LOCATE Y + 1, typBut.Inx
      PRINT sTemp
      LOCATE Y + 2, typBut.Inx
      PRINT sBottom
      Y = Y + 3
      typBut.Inx = typBut.Inx + 1
      typBut.Focus = 1
      GOTO OK_Cancel
  END SELECT
  IF typBox.BoxTyp THEN typB = typBut
END SUB

FUNCTION CONTROL(active AS LONG)AS LONG
STATIC MenuItems() AS Umenu
STATIC Items AS MenuMain
STATIC NumItems AS LONG
LOCAL lResult   AS LONG
LOCAL I         AS LONG
LOCAL RodentX AS LONG    'Mouse Cursor Column
LOCAL RodentY AS LONG    'Mouse Cursor Row
LOCAL RodentB AS LONG    'Mouse Cursor Button
  I = 1
  REDIM MenuItems(I TO I)
  CALL InitMenu(MenuItems(), Items)  'initialize variables
  CURSOR OFF
  IF active THEN  'if control(active) is 1 menu at startup
    CALL ShowBar(Items)
    lresult = MENU(Items, MenuItems())
    CONTROL = lresult
  ELSE
    SELECT CASE keypress(RodentX, RodentY, RodentB)
      CASE -50
        lresult = MENU(Items, MenuItems())
        CONTROL = lresult
      CASE ELSE : CONTROL = 0
    END SELECT
  END IF
  CURSOR ON
END FUNCTION

#IF %test
FUNCTION PBMAIN
LOCAL lresult AS LONG
CONSOLE SCREEN 28, 80     ' set screen 28X80
  DoubleClick = 1   'double click on left mouse button, 0 for single click
  MOUSE ON
  IF DoubleClick THEN
    MOUSE 1, DOUBLE, MOVE, DOWN
  ELSE
    MOUSE 1, MOVE, DOWN
  END IF
  DO    ' program control loop
    COLOR 15,1  ' screen background color
    CLS    ' erase screen
    COLOR 15,9  ' color for status line
    LOCATE 28,1 ' go to bottom info line
    PRINT STRING$(80," ");     ' clear other text
    LOCATE 28,1 ' go to bottom line
    PRINT("<ALT><M> for menu <ESC> to exit menu");
    lresult = CONTROL(1)  ' 1 = active menu 0 = <alt><m> menu
    IF lresult = 16 THEN  ' call message box
      REDIM Mess(1 TO 2) AS STRING
      Mess(1) = "   Are you sure you want to quit?"
      Mess(2) = "Any unsaved information will be lost."
      lresult = MSGBOX(2,   Mess(), 14,      9,     14,    12)
      '               (type,array,regtext,regback,hitext,hiback)
      IF lresult = 21 THEN               ' yes to exit
        EXIT                             ' EXIT from menu exits program
      ELSE
        lresult = 0                      ' nullify lresult
      END IF
    END IF
    LOCATE 14,1                          ' menu return code test lines
    COLOR 15,1                           '   |
    PRINT("Return Code: "+STR$(lresult));'   |
    WAITKEY$                             '   V
    'return code handler here
    ' select option by menu return
    'user code here
    ' program activation start
  LOOP     ' round and round until = exit code
END FUNCTION
#ENDIF