home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
DP Tool Club 24
/
CD_ASCQ_24_0995.iso
/
vrac
/
homonlib.zip
/
LISTBOX.BAS
< prev
next >
Wrap
BASIC Source File
|
1995-04-13
|
8KB
|
229 lines
DEFINT A-Z
' $INCLUDE: 'PARM.INC'
' $INCLUDE: 'SETCURS.INC'
DECLARE FUNCTION ListBox (title$, choice$(), parm())
'External procedures:
DECLARE SUB Box (t, l, b, r, b$)
DECLARE SUB BoxCalc (t, l, b, r, tall, wide)
DECLARE FUNCTION GetKey$ (parm())
DECLARE FUNCTION PadR$ (t$, l)
DECLARE FUNCTION Istr$ (i)
DECLARE SUB RestScreen (f$)
DECLARE SUB SaveScreen (f$)
DECLARE SUB SetView (t, b, parm())
DECLARE FUNCTION TempName$ (p$)
DECLARE FUNCTION VPage (p)
FUNCTION ListBox (title$, choice$(), parm())
'****************************************************************************
'ListBox() works just like PickOne(), but it appears in a pop-up box. It
' returns the element number of the item selected or zero if the user pressed
' ESC. There are no hotkeys in ListBox().
'
'The title$ argument will be centered on the top border of the box. If no
' title is desired, pass a null string.
'
'The width of the box is determined by the longer of the title or longest
' choice$() element.
'
' parm(1) = top row 0=Center
' parm(2) = left column 0=Center
' parm(3) = box border type 1-4. See SUB Panes() for numeric boxtypes.
' parm(4) = initial selected choice
'
'****************************************************************************
' *** Preliminary calculations ***
min = LBOUND(choice$) 'Get information about choice$().
max = UBOUND(choice$)
wide = LEN(title$) 'Find out how wide & tall to make the
IF wide > 0 THEN wide = wide + 2 'box. Allow for the title's frame.
FOR x = min TO max
tall = tall + 1
l = LEN(choice$(x))
IF l > wide THEN wide = l
NEXT x
IF tall > 10 THEN tall = 10
row1 = parm(1) 'Find out where to place the box.
col1 = parm(2)
BoxCalc row1, col1, row2, col2, tall, wide
' *** Draw the Box ***
oldrow = CSRLIN 'Save the current cursor location
oldcol = POS(0)
oldcursor = SetCursor(SCNONE) 'Turn the cursor off
savepage = VPage(0) 'Allocate a video page to save the
IF savepage = 0 THEN 'current screen on. If unable to get
savefile$ = TempName$("") 'one, we'll have to use the slower
SaveScreen savefile$ 'method of saving it to an actual
ELSE 'file.
PCOPY 0, savepage
END IF
workpage = VPage(0) 'Allocate a non-critical video page.
PCOPY 0, workpage 'Copy the screen to the scratch page.
SCREEN , , workpage, 0 'Draw on the work page until ready.
COLOR parm(FGWB), parm(BGWB) 'Draw the outline & title
Box row1, col1, row2, col2, Istr$(parm(3))
SELECT CASE parm(3)
CASE 2
lc$ = CHR$(181)
rc$ = CHR$(198)
v$ = CHR$(186)
CASE 3
lc$ = CHR$(181)
rc$ = CHR$(198)
v$ = CHR$(179)
CASE 4
lc$ = CHR$(180)
rc$ = CHR$(195)
v$ = CHR$(186)
CASE ELSE
lc$ = CHR$(180)
rc$ = CHR$(195)
v$ = CHR$(179)
END SELECT
IF LEN(title$) THEN
x = wide - (LEN(title$) + 2)
LOCATE row1, col1 + (x \ 2) + 1
PRINT lc$; title$; rc$;
END IF
COLOR 0, 0 'Print the shadow
l = col2 + 1
FOR x = (row1 + 1) TO row2
LOCATE x, l: PRINT " "
NEXT x
LOCATE row2 + 1, col1 + 1: PRINT SPACE$(wide + 2);
PCOPY workpage, 0 'Pop the box onto the screen.
SCREEN , , 0, 0 'Draw on screen 0 again.
x = VPage(workpage) 'Release the scratch video page.
' *** Pick a choice, any choice! ***
sel = parm(4) 'Initially position the list.
IF sel < min OR sel > max THEN sel = min
top = min
bot = top + tall - 1
DO WHILE bot < sel
top = top + 1
bot = bot + 1
LOOP
col = col1 + 1
id$ = CHR$(18) 'The little indicator character.
irow = row1 + 1
COLOR parm(FGWT), parm(BGWT)
DO 'The main loop!
row = row1 'Print the choices.
FOR x = top TO bot
row = row + 1
IF x = sel THEN COLOR parm(FGWS), parm(BGWS)
LOCATE row, col
PRINT PadR$(choice$(x), wide)
COLOR parm(FGWT), parm(BGWT)
NEXT x
IF tall = 10 THEN 'Put an indicator on the side.
COLOR parm(FGWB), parm(BGWB)
LOCATE irow, col2
PRINT v$;
x = INT((sel / max) * 10)
IF x < 1 THEN x = 1
irow = row1 + x
LOCATE irow, col2
PRINT id$;
COLOR parm(FGWT), parm(BGWT)
END IF
k$ = GetKey$(parm()) 'Get keyboard input
SELECT CASE ASC(LEFT$(k$, 1))
CASE 27 'ESC
ListBox = 0
EXIT DO
CASE 13 'Enter
ListBox = sel
EXIT DO
CASE 0
SELECT CASE ASC(RIGHT$(k$, 1))
CASE 72 'Up arrow
sel = sel - 1
IF sel < min THEN sel = min
IF sel < top THEN
top = top - 1
bot = bot - 1
END IF
CASE 80 'Down arrow
sel = sel + 1
IF sel > max THEN sel = max
IF sel > bot THEN
top = top + 1
bot = bot + 1
END IF
CASE 73 'PgUp
IF top > min THEN
top = top - tall
bot = bot - tall
IF top < min THEN
top = min
bot = top + tall - 1
END IF
IF sel > bot THEN sel = bot
END IF
CASE 81 'PgDn
IF bot < max THEN
top = top + tall
bot = bot + tall
IF bot > max THEN
bot = max
top = bot - tall + 1
END IF
IF sel < top THEN sel = top
END IF
CASE 71 'Home
sel = min
top = min
bot = top + tall - 1
CASE 79 'End
sel = max
bot = max
top = bot - tall + 1
CASE ELSE
'Ignore it
END SELECT
CASE ELSE
'Ignore it
END SELECT
LOOP
' *** Clean up after ourselves ***
IF savepage = 0 THEN 'Restore the previous screen.
RestScreen savefile$
KILL savefile$
ELSE
PCOPY savepage, 0
x = VPage(savepage)
END IF
x = SetCursor(oldcursor) 'Restore the cursor.
COLOR parm(FGN), parm(BGN) 'Set colors to normal.
SetView -1, -1, parm() 'Restore the previous viewport.
LOCATE oldrow, oldcol 'Put the cursor back where it was.
END FUNCTION