Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : MENUBAR.ZIP
Filename : MENUBAR.PRG

****************************************************************************
* MENUBAR.PRG - Turn menu choices into 1-2-3 style bar menu *
* *
* Version 1.2 3/24/87 *
* Copyright 1987 *
* Brian Gardner *
* Centra, Inc. 5156 Sinclair Road, Columbus, Ohio 43229 *
* 614-846-5200 (voice) *
****************************************************************************
* CALLING PROGRAM MUST PROVIDE THE FOLLOWING PARAMETERS
* MENUTITLE - a string containing all the menu choices, delimited by
* underscores
* BOXTYPE - a string describing the type of box to paint around it
* ('sgl' and 'dbl' are the only choices)
* TROW - the number of the row of the top of the box
* TCOL - the number of the column of the left side of the box
* MENUWIDTH - the number of the width of the bars (whatever your widest
* selection is, plus a bit more...)
* MCLEAR - a string that flags whether or not to clear the screen after
* selection ('y' and 'n' are the only choices)
*
* DO MENUBAR WITH 'menutitle','boxtype',trow,tcol,menuwidth,'mclear'
*
* for example:
* DO Menubar WITH 'Add Titles_Edit Titles_Print Reports_Quit_',;
* 'dbl',5,10,25,'y'
*
* If the user presses , the program will assume the last choice
* you give (usually Quit, or Return to Main Menu). That way you can nest
* these little fellows without worrying about falling through to dBASE
*
*
*=========================================================================*

* you may want to initialize mchoice from the calling program,
* in which case you would delete the next line of code.
PUBLIC mchoice && gets returned to the caller

PARAMETERS menutitle, boxtype, trow, tcol, menuwidth, mclear
normal = 'w/n' && video attributes, if you have a color monitor, you
inverse = 'n/w' && can change these to suit your preferences
num = 1
fletters = ''

DO WHILE .T. && parse menutitle
nbr = LTRIM(STR(num)) && make our counter a string for the macro
*------ extract the next item and the first letter
fletters = fletters + UPPER(SUBSTR(menutitle,1,1))
menu&nbr = STUFF(SPACE(menuwidth),INT((menuwidth - LEN(SUBSTR;
(menutitle,1,AT('_',menutitle)-1)))/2),LEN(SUBSTR(menutitle,1,AT('_',;
menutitle)-1)),SUBSTR(menutitle,1,AT('_',menutitle)-1))
IF AT('_',menutitle) = LEN(menutitle) && more titles?
EXIT
ELSE
menutitle = SUBSTR(menutitle,AT('_',menutitle)+1) && clip off the
num = num + 1 && one extracted
LOOP
ENDIF
ENDDO

numrows = num && how many rows total do we have?
botrow = trow + numrows + 1 && box bottom
bcol = tcol + menuwidth + 2 && box right hand side
@ trow, tcol CLEAR TO botrow, bcol && clear and make the box
IF boxtype = 'sgl' .OR. boxtype = 'SGL'
@ trow, tcol TO botrow, bcol
ELSE
@ trow, tcol TO botrow, bcol DOUBLE
ENDIF
maxnum = num
nextrow = trow
num = 1

DO WHILE num <= maxnum && insert the menu items
nbr = LTRIM(STR(num)) && string for macro
@ nextrow + num,tcol+1 SAY menu&nbr && say each item in normal video
num = num + 1
ENDDO

SET COLOR TO &inverse && place the highlight in the first row
@ nextrow + 1,tcol+1 SAY menu1 && say first menu item in inverse video
topmenu = trow + 1
botmenu = botrow - 1
currow = topmenu
num = 1
gotinput = .F.

DO WHILE .NOT. gotinput
nbr = LTRIM(STR(num)) && counter string for the macro
key = INKEY()
DO WHILE key = 0 && waiting for keypress
key = INKEY()
ENDDO
DO CASE
*------ if input is direction, restore current row, highlight choice row
CASE key = 24 .OR. key = 4 && down or right arrow
SET COLOR TO &normal
@ currow, tcol+1 SAY menu&nbr
SET COLOR TO &inverse
IF currow = botmenu && around to the top please!
num = 1
currow = topmenu
ELSE
num = num + 1
currow = currow + 1
ENDIF
nbr = LTRIM(STR(num))
@ currow, tcol+1 SAY menu&nbr
LOOP
CASE key = 5 .OR. key = 19 && up or left arrow
SET COLOR TO &normal
@ currow, tcol+1 SAY menu&nbr
SET COLOR TO &inverse
IF currow = topmenu && around to the bottom!
num = numrows
currow = botmenu
ELSE
num = num - 1
currow = currow - 1
ENDIF
nbr = LTRIM(STR(num))
@ currow, tcol+1 SAY menu&nbr
LOOP
CASE key = 1 .OR. key = 18 && home or pageup
SET COLOR TO &normal
@ currow, tcol+1 SAY menu&nbr
SET COLOR TO &inverse
num = topmenu
currow = topmenu
num = 1
nbr = LTRIM(STR(num))
@ currow, tcol+1 SAY menu&nbr
LOOP
CASE key = 6 .OR. key = 3 && end or pagedown
SET COLOR TO &normal
@ currow, tcol+1 SAY menu&nbr
SET COLOR TO &inverse
num = botmenu
currow = botmenu
num = numrows
nbr = LTRIM(STR(num))
@ currow, tcol+1 SAY menu&nbr
LOOP
*------ if , , or letter hit,
CASE key = 27 && an key was hit, assume the last choice
SET COLOR TO &normal
nbr = LTRIM(STR(numrows))
EXIT
CASE key = 13 && was hit. take current choice and return
SET COLOR TO &normal
EXIT
CASE UPPER(CHR(key)) $ fletters && one of our letters was hit
SET COLOR TO &normal
@ currow, tcol+1 SAY menu&nbr
numcount = 1
DO WHILE numcount <= numrows
charcheck = SUBSTR(fletters,numcount,1)
IF UPPER(charcheck) = UPPER(CHR(KEY))
nbr = LTRIM(STR(numcount))
EXIT
ELSE
numcount = numcount + 1
ENDIF
ENDDO
SET COLOR TO &inverse
@ topmenu+VAL(nbr)-1, tcol+1 SAY menu&nbr
SET COLOR TO &normal
EXIT
OTHERWISE
LOOP
ENDCASE
ENDDO

IF mclear = 'y'.OR. mclear = 'Y'
@ trow, tcol CLEAR TO botrow, bcol
ENDIF
mchoice = nbr && this is how we return the choice to the calling prg
RETURN
*
***** end of menubar.prg