'===========================================================================
' Subject: PICK LIST DEMO                    Date: 10-13-96 (12:20)       
' Author:  Charles Godard                    Code: QB, PDS                
' Origin:  FidoNet QUIK_BAS Echo           Packet: MENU.ABC
'===========================================================================
' >Anyone out there have any code examples for a pick list box ? Mouse support
' >would be a welcome addtion :)
'
'Here is one I've been working on, off and on.  It's not polished
'and I haven't started programming with the mouse yet, but maybe
'you can polish it up and use it.
'                              Picklist.bas
'                           By Charles Godard
'                               10/12/96
DEFINT A-Z
'$INCLUDE: 'qb.bi'   'give it a path to qb.bi
DIM SHARED Inreg AS regtypex, outreg AS regtypex
 TYPE BoxType
  Char AS STRING * 1
  Attr AS STRING * 1
 END TYPE
 TYPE boxParameters
  scrn AS INTEGER
  Tr AS INTEGER
  Br AS INTEGER
  Lc AS INTEGER
  Rc AS INTEGER
 END TYPE
COMMON SHARED Box() AS BoxType, bp AS boxParameters
'***Duplicate the common shared and TYPE def when calling from another***
'***program module.  Exact duplicates are advised! ...................***
SCREEN 0
CLS
COLOR &H7, &H9: FOR i = 0 TO 999: PRINT CHR$(3); " "; : NEXT
DIM Item(8)  AS STRING   'dim to only as many items
Item(0) = "  Zero   "     'as you will use in list
Item(1) = "  One    "
Item(2) = "  Two    ": Item(3) = "  Three  "
Item(4) = "  Four   ": Item(5) = "  Five   "
Item(6) = "  Six    ": Item(7) = "  Seven  "
Item(8) = "  Eight  "
Selected% = Picklist(10, 35, 8, 3, Item())
COLOR &H1E
LOCATE 12, 31: PRINT "You selected Item: "; Selected%
COLOR &HE
SLEEP

SUB ClosePicklist
	 scrn = bp.scrn
	 Tr = bp.Tr
	 Br = bp.Br
	 Lc = bp.Lc
	 Rc = bp.Rc
 FOR x = Tr TO Br
 FOR y = Lc TO Rc
  LOCATE x, y:
  fg = ASC(Box(x, y).Attr) AND &HF
  bg = (ASC(Box(x, y).Attr) \ &H10)
  COLOR fg, bg
  PRINT Box(x, y).Char
 NEXT y, x
scrn = scrn - 1
END SUB

'Waits for a sinlge keystroke and returns the function keys as a
'minus number
FUNCTION GetKey%
	 Inreg.ax = &H0
	 INTERRUPTX &H16, Inreg, outreg
 LoVal% = outreg.ax AND &HFF  'returns Lo byte as ascii keys + #
		  'hi-byte as - # (function keys)
 IF LoVal% = 0 THEN
  GetKey% = -(outreg.ax AND &HFF00) \ &H100
 ELSE
  GetKey% = outreg.ax AND &HFF
 END IF
END FUNCTION

FUNCTION Picklist% (Tr%, Lc%, W%, H%, Item() AS STRING)
Lines = UBOUND(Item)
IF H > Lines THEN H = Lines
Br = Tr + H: Rc = Lc + W
QBasicPU Tr, Br, Lc, Rc, &H34, "Choose"
offset = 1:
Scroll 0, Tr - 1, Br - 1, Lc - 1, Rc - 1, &H17, Br - Tr + 1
 FOR Ct = 0 TO H
  IF Ct < Br - Tr + 1 THEN   'scrolls up
   Scroll 0, Tr - 1, Br - 1, Lc - 1, Rc - 1, &H17, 1
   LOCATE Br, Lc
   COLOR &H7, 4
   PRINT Item(E%);
  END IF
  E% = E% + 1
 NEXT
   'hi-lite the 1st line
   Ct = 0  'reset it for reuse
   LOCATE Tr, Lc: COLOR &HF, 4
   PRINT MID$(Item(Ct), offset, W%)
   IF bxRow < Tr THEN bxRow = Tr

DO
   KeyP% = GetKey%
   SELECT CASE KeyP%
	 CASE IS = 13, 32
	    Selected% = Ct
	    LOCATE 10, 1
	    'PRINT Selected%
	    Picklist = Selected%
	    ClosePicklist
	    EXIT FUNCTION
	 CASE IS = -80 'arrow Dn     SCROLL THE COMMANDS
	    Ct = Ct + 1  'keeps track of the element
	    IF Ct > Lines THEN   ' limits # of variables to # of
		  Ct = Lines     ' lines in file.
	    ELSE
		  IF bxRow < Tr THEN bxRow = Tr  'sets top limit of
		  bxRow = bxRow + 1               'where scroll begins
		  'scrolls PRINTING down the 1st page
		  IF bxRow < Br + 1 THEN
			LOCATE bxRow, Lc: COLOR &HF, 4
			PRINT MID$(Item(Ct), offset, W%)
			LOCATE bxRow - 1, Lc: COLOR &H7, 4
			PRINT MID$(Item(Ct - 1), offset, W%)
		  ELSE
			'scrolls SCREEN UP prints to Bottom line on the 2nd page
			'colors the last line
			LOCATE Br, Lc: COLOR 7, 4
			PRINT MID$(Item(Ct - 1), offset, W%)
			Scroll 0, Tr - 1, Br - 1, Lc - 1, Rc - 1, &H17, 1
			LOCATE Br, Lc: COLOR &HF, 4
			PRINT MID$(Item(Ct), offset, W% + 1)
			IF bxRow > Br THEN bxRow = Br
		  END IF
	    END IF
	 CASE IS = -72       'arrrow Up   
	    'scrolls SCREEN DN prints to the top line of 1st page
	    IF (bxRow <= Tr) AND Ct >= 1 THEN
		  bxRow = bxRow - 1: Ct = Ct - 1
		  LOCATE Tr, Lc: COLOR &H7, 4
		  PRINT MID$(Item(Ct + 1), offset, W%)
		  Scroll 1, Tr - 1, Br - 1, Lc - 1, Rc - 1, &H17, 1
		  LOCATE Tr, Lc: COLOR &HF, 4
		  PRINT MID$(Item(Ct), offset, W% + 1)
	    ELSE
		  'scrolls PRINTING UP the page when not on 1st line
		  IF Ct >= 1 THEN
			bxRow = bxRow - 1: Ct = Ct - 1
			LOCATE bxRow, Lc: COLOR &HF, 4
			PRINT MID$(Item(Ct), offset, W%)
			LOCATE bxRow + 1, Lc: COLOR &H7, 4
			PRINT MID$(Item(Ct + 1), offset, W%)
		  END IF
	    END IF
   END SELECT
LOOP UNTIL KeyP% = 27
ClosePicklist
END FUNCTION

SUB QBasicPU (Tr%, Br%, Lc%, Rc%, Attr%, Title$)
 bp.scrn = bp.scrn + 1
 bp.Tr = Tr
 bp.Br = Br
 bp.Lc = Lc
 bp.Rc = Rc
REDIM Box(Br, Rc)  AS BoxType
 FOR x = Tr TO Br
 FOR y = Lc TO Rc
  Box(x, y).Attr = CHR$(SCREEN(x, y, 1))
  Box(x, y).Char = CHR$(SCREEN(x, y))
 NEXT y, x
 bg = Attr AND &HF: fg = Attr \ &H10
 COLOR fg, bg
 FOR x = Tr TO Br
  LOCATE x, Lc, 0
  PRINT STRING$(Rc - Lc, CHR$(32))
 NEXT x
END SUB

SUB Scroll (dir%, upperRow, lowerRow, leftCol, rightCol, Attr%, Lines%)
IF dir% = 0 THEN dir% = &H6 ELSE dir% = &H7
'6 is up   :      7 is down
 Inreg.ax = (dir% * &H100) + Lines%
 Inreg.bx = Attr% * &H100
 Inreg.cx = (upperRow * &H100) + leftCol
 Inreg.dx = (lowerRow * &H100) + rightCol
 INTERRUPTX &H10, Inreg, outreg   'no return
END SUB