'$INCLUDE: 'dialog.bi'
' prints a button
'
SUB btnPrintItem (Info() AS ButtonItemType, Item AS INTEGER, High AS INTEGER)
COLOR 0, 7
LOCATE Info(Item).Row, Info(Item).Col
PRINT "< "; RTRIM$(Info(Item).Caption); " >";
IF High THEN
COLOR 15, 7
LOCATE Info(Item).Row, Info(Item).Col + 1 + Info(Item).HotKey
PRINT MID$(Info(Item).Caption, Info(Item).HotKey, 1);
END IF
LOCATE Info(Item).Row, Info(Item).Col + 2, 1, 6, 7
END SUB
SUB DirList (Array() AS STRING, parent AS STRING, ReturnValue AS INTEGER, FileName AS STRING)
' Function ReturnValues
' ---------------------
' 0 = All
' 1 = Directories only
' 2 = Files only
DIM ch1 AS STRING * 1
cm$ = ","
sp$ = " "
' remove the final slash (it would cause an error)
IF RIGHT$(parent, 1) = "/" OR RIGHT$(parent, 1) = "\" THEN MID$(parent, LEN(parent), 1) = " "
' use DOS to build the file list
' group directories, sort by name, wide format
SHELL "dir /o:gn /w " + parent + " > filelist.txt"
' format the file to read every record sequentially
OPEN "filelist.txt" FOR BINARY AS #1
FOR x = 1 TO LOF(1)
GET #1, x, ch1
IF ch1 = CHR$(9) OR ch1 = CHR$(10) THEN PUT #1, x, cm$
IF ch1 = CHR$(1) OR ch1 = CHR$(13) THEN PUT #1, x, sp$
NEXT x
CLOSE
' open the file to read the file names
OPEN "filelist.txt" FOR INPUT AS #1
' get a record count. subtract 7 records for the header and trailer
allcount = -7
DO UNTIL EOF(1)
INPUT #1, xr$
allcount = allcount + 1
LOOP
SEEK #1, 1
' exit the sub if an error occured
IF allcount > 0 THEN
' allocate temporary memory
DIM temparray(1 TO allcount) AS STRING
' skip the header
FOR x = 1 TO 5
INPUT #1, xr$
NEXT x
' read the files into the array, stop before trailer
FOR x = 1 TO allcount
INPUT #1, temparray(x)
NEXT x
' count the number of directories in the list
FOR x = 1 TO allcount
IF LEFT$(temparray(x), 1) = "[" AND INSTR(temparray(x), "]") THEN
dircount = dircount + 1
ELSE
EXIT FOR
END IF
NEXT x
' determine the data to return
SELECT CASE ReturnValue
CASE 0 ' All
start = 1
finish = allcount
CASE 1 ' Directories only
start = 1
finish = dircount
CASE 2 ' Files only
start = dircount + 1
finish = allcount
END SELECT
' copy the appropriate data
REDIM Array(1 TO finish - start + 1) AS STRING
FOR x = start TO finish
Array(x - start + 1) = temparray(x)
NEXT x
ReturnValue = finish - start + 1
END IF
' save the data in a file if specified
IF FileName > "" THEN
OPEN FileName FOR OUTPUT AS #2
FOR x = 1 TO UBOUND(Array, 1)
WRITE #2, Array(x)
NEXT x
END IF
CLOSE
KILL "filelist.txt"
END SUB
' prints an input box
'
SUB inpPrintItem (Info AS InputType)
DIM a AS STRING
IF Info.Border THEN CALL scrBox(Info.Corner.T, Info.Corner.L, Info.Corner.B, Info.Corner.R, Info.Shadow)
COLOR 0, 7
IF NOT Null(Info.Caption) THEN
LOCATE Info.Corner.T, Info.Corner.L + 1
PRINT " "; RTRIM$(Info.Caption); " ";
END IF
END SUB
' returns TRUE if either ALT key is pressed
'
FUNCTION kbALT%
IF PEEK(1047) AND 8 THEN kbALT = TRUE
END FUNCTION
' returns TRUE if either CTRL key is pressed
'
FUNCTION kbCTRL%
IF PEEK(1047) AND 4 THEN kbCTRL = TRUE
END FUNCTION
' flushes the keyboard buffer
'
SUB kbFlush
DEF SEG = 0
POKE 1052, PEEK(1050)
END SUB
' returns TRUE if the LEFT SHIFT key is pressed
'
FUNCTION kbLSHIFT%
IF PEEK(1047) AND 1 THEN kbLSHIFT = TRUE
END FUNCTION
' returns TRUE if the RIGHT SHIFT key is pressed
'
FUNCTION kbRSHIFT%
IF PEEK(1047) AND 2 THEN kbRSHIFT = TRUE
END FUNCTION
' returns TRUE if the key requested (by scan code) is being pressed
'
FUNCTION kbScan% (k AS INTEGER)
kbScan = FALSE
IF INP(96) = k THEN kbScan = TRUE
kbFlush
END FUNCTION
' returns the letter value of the given scan code
'
FUNCTION kbScanKey$ (code%)
IF code% = 0 THEN code% = INP(96)
kbScanKey$ = ""
SELECT CASE code%
CASE &H10 TO &H19
kbScanKey$ = MID$("qwertyuiop", code% - &HF, 1)
CASE &H1E TO &H26
kbScanKey$ = MID$("asdfghjkl", code% - &H1D, 1)
CASE &H2C TO &H32
kbScanKey$ = MID$("zxcvbnm", code% - &H2B, 1)
END SELECT
END FUNCTION
' returns TRUE if either SHIFT key is pressed
'
FUNCTION kbSHIFT%
Tx = PEEK(1047) AND 15
IF Tx AND 1 OR Tx AND 2 THEN kbSHIFT = TRUE
END FUNCTION
' scans the list for which hot key was pressed
'
FUNCTION lstHotKey (Array() AS ListBoxItemType, Info AS ListBoxGroupType, kb$)
DIM x AS INTEGER
FOR x = 1 TO Info.ItemCount
IF Array(x).HotKey > 0 THEN
IF LCASE$(MID$(Array(x).Caption, Array(x).HotKey, 1)) = kb$ THEN
Info.ItemCurrent = x
lstHotKey = TRUE
EXIT FOR
END IF
END IF
NEXT x
END FUNCTION
' loads the list from the specified file
'
SUB lstLoad (Array() AS ListBoxItemType, Info AS ListBoxGroupType)
DIM x AS INTEGER
DIM Pointer AS INTEGER
DIM Readin AS STRING
' find list size and reallocate memory
CALL lstMaxData(Info)
REDIM Array(1 TO Info.ItemCount + 1) AS ListBoxItemType
IF Info.FileName > "" THEN
' open the data file
DIM FileNum AS INTEGER
FileNum = FREEFILE
OPEN Info.FileName FOR INPUT AS FileNum
END IF
' load the items
FOR x = 1 TO Info.ItemCount
IF FileNum > 0 THEN
INPUT #FileNum, Readin
ELSE
READ Readin
END IF
' trim the list item
Readin = LTRIM$(RTRIM$(Readin))
' isolate the hot key
Pointer = INSTR(Readin, "&")
IF Pointer > 0 THEN
Array(x).HotKey = Pointer
Readin = LEFT$(Readin, Pointer - 1) + MID$(Readin, Pointer + 1)
END IF
' save the item
Array(x).Caption = Readin
' find max width for mulitiple columns
IF LEN(Readin) > Info.ColWidth THEN Info.ColWidth = LEN(Readin)
NEXT x
' adjust the column width
BoxWidth = Info.Corner.R - Info.Corner.L
IF NOT Info.ColMulti THEN
Info.ColWidth = BoxWidth
ELSE
Info.ColWidth = Info.ColWidth + 4
END IF
' cancel mutlicol or narrow single column if box width is not big enough
IF Info.ColWidth > BoxWidth THEN
Info.ColMulti = FALSE
Info.ColWidth = BoxWidth
END IF
' set the Row and Col for each item relative to the box
Info.MaxSet = Info.Corner.B - Info.Corner.T - 1
Col = 1
Row = 1
FOR x = 1 TO Info.ItemCount + 1
Array(x).Col = Col
Array(x).Row = Row
Row = Row + 1
IF Info.ColMulti THEN
IF Row > Info.MaxSet THEN
Col = Col + 1
Row = 1
END IF
END IF
NEXT x
' save/set default data
Info.ColTop = 1
Info.ColCount = Col
Info.ColShow = INT((Info.Corner.R - Info.Corner.L - 1) \ Info.ColWidth + .999)
Info.ColCurrent = 1
Info.ItemTop = 1
Info.ItemCurrent = 1
' error checking
IF Info.ColShow < 1 THEN Info.ColShow = 1
' set last indice to blank
Array(Info.ItemCount + 1).HotKey = -1
IF FileNum > 0 THEN CLOSE FileNum
END SUB
' finds the list size and reallocates memory
'
SUB lstMaxData (Info AS ListBoxGroupType)
DIM x AS INTEGER
DIM Readin AS STRING
DIM FileNum AS INTEGER
' open the data file
IF Info.FileName > "" THEN
FileNum = FREEFILE
OPEN Info.FileName FOR INPUT AS #FileNum
INPUT #FileNum, Readin
ELSE
READ Readin
END IF
' read all items in the file
DO UNTIL Readin = "EOF" OR EOF(FileNum)
' keep count of all items
Info.ItemCount = Info.ItemCount + 1
IF FileNum THEN
INPUT #FileNum, Readin
ELSE
READ Readin
END IF
LOOP
IF FileNum THEN CLOSE FileNum
END SUB
' prints a single list item
'
SUB lstPrintItem (Item AS ListBoxItemType, Info AS ListBoxGroupType, High AS INTEGER)
IF Info.ItemCount < 1 OR Info.ItemCurrent < 1 OR Info.ColWidth < 1 THEN EXIT SUB
' find the position relative to the screen
IF Info.ColMulti THEN
Col = Info.Corner.L
Col = Col + ((Info.ColCurrent - Info.ColTop) * Info.ColWidth) + 1
Row = Info.Corner.T + Item.Row
IF Item.HotKey = -1 THEN
FOR x = Row TO Info.Corner.B - 1
LOCATE x, Col
PRINT SPACE$(Info.ColWidth);
NEXT x
EXIT SUB
END IF
ELSE
Row = Info.Corner.T + Item.Row - Info.ItemTop + 1
Col = Info.Corner.L + Item.Col
END IF
LOCATE Row, Col
IF Info.ListType = cstOPT OR Item.ListType = cstOPT THEN
COLOR 0, 7
PRINT " ( ) "; RTRIM$(Item.Caption); SPC(Info.ColWidth - LEN(RTRIM$(Item.Caption)) - 7); " ";
IF High THEN
LOCATE Row, Col + 2
CALL scrPrint(7, 0, 7)
END IF
IF Item.HotKey > 0 THEN
COLOR 15
LOCATE Row, Col + 4 + Item.HotKey
PRINT MID$(Item.Caption, Item.HotKey, 1);
END IF
LOCATE Row, Col + 2, 1
ELSEIF Info.ListType = cstCHECK OR Item.ListType = cstCHECK THEN
COLOR 0, 7
PRINT " [ ] "; RTRIM$(Item.Caption); SPC(Info.ColWidth - LEN(RTRIM$(Item.Caption)) - 7); " ";
LOCATE Row, Col + 2
IF Item.ItemCurrent THEN PRINT "X";
IF Item.HotKey > 0 THEN
COLOR 15
LOCATE Row, Col + 4 + Item.HotKey
PRINT MID$(Item.Caption, Item.HotKey, 1);
END IF
LOCATE Row, Col + 2, 1
ELSE
IF High THEN COLOR 7, 0 ELSE COLOR 0, 7
PRINT " "; RTRIM$(Item.Caption); SPC(Info.ColWidth - LEN(RTRIM$(Item.Caption)) - 3); " ";
IF Item.HotKey > 0 THEN
COLOR 15
LOCATE Row, Col + Item.HotKey
PRINT MID$(Item.Caption, Item.HotKey, 1);
END IF
LOCATE Row, Col + 1, 1
END IF
END SUB
' prints the list
'
SUB lstShow (Array() AS ListBoxItemType, Info AS ListBoxGroupType, ItemsOnly)
STATIC FirstCall AS INTEGER
DIM x AS INTEGER
DIM OldSelect AS INTEGER
IF Info.ItemTop < 1 AND Info.ItemCount > 1 THEN Info.ItemTop = 1
IF NOT Info.NoBorder AND NOT FirstCall THEN
CALL scrBox(Info.Corner.T, Info.Corner.L, Info.Corner.B, Info.Corner.R, TRUE)
IF NOT Null(Info.Title) THEN
LOCATE Info.Corner.T, Info.Corner.L + 1
COLOR 0, 7
PRINT " "; RTRIM$(Info.Title); " ";
END IF
IF Info.VScrollBar THEN
' print arrows
LOCATE Info.Corner.T + 1, Info.Corner.R
CALL scrPrint(24, 0, 7)
LOCATE Info.Corner.B - 1, Info.Corner.R
CALL scrPrint(25, 0, 7)
' print scroll bar
FOR x = Info.Corner.T + 2 TO Info.Corner.B - 2
LOCATE x, Info.Corner.R
PRINT CHR$(176);
NEXT x
END IF
' remember this routine was already called
FirstCall = TRUE
END IF
' print as many items as possible
IF Info.ItemCount > 0 THEN
IF Info.ColMulti THEN
OldTop = Info.ItemTop
OldCol = Info.ColCurrent
FOR y = Info.ColTop TO Info.ColTop + Info.ColShow - 1
Info.ColCurrent = y
Info.ItemTop = (Info.ColCurrent - 1) * Info.MaxSet + 1
FOR x = Info.ItemTop TO Info.ItemTop + Info.MaxSet - 1
IF x > Info.ItemCount THEN
CALL lstPrintItem(Array(Info.ItemCount + 1), Info, FALSE)
ELSE
CALL lstPrintItem(Array(x), Info, FALSE)
END IF
NEXT x
NEXT y
Info.ItemTop = OldTop
Info.ColCurrent = OldCol
ELSE
FOR x = Info.ItemTop TO Info.ItemTop + Info.MaxSet - 1
CALL lstPrintItem(Array(x), Info, FALSE)
NEXT x
END IF
END IF
END SUB
' main routine for the 'BUTTON' element
'
SUB Main.Button (Array() AS ButtonItemType, Info AS ButtonGroupType)
DIM High AS INTEGER
DIM x AS INTEGER
x = Info.Current
LOCATE Array(x).Row, Array(x).Col + 2, 1, 6, 7
DO
kb$ = INKEY$
IF kbALT THEN
CALL btnPrintItem(Array(), x, TRUE)
WHILE kbALT
kb$ = INKEY$
IF LCASE$(RIGHT$(kb$, 1)) = LCASE$(MID$(Array(x).Caption, Array(x).HotKey, 1)) THEN
Info.Selected = x
EXIT DO
END IF
WEND
END IF
IF kb$ = CHR$(cstENTER) THEN
Info.Selected = x
EXIT DO
ELSEIF LCASE$(RIGHT$(kb$, 1)) = LCASE$(MID$(Array(x).Caption, Array(x).HotKey, 1)) THEN
Info.Selected = x
EXIT DO
END IF
LOOP UNTIL kb$ = CHR$(cstTAB) OR kb$ = CHR$(cstESC)
END SUB
' main routine for the 'INPUTBOX' element
'
FUNCTION Main.InputBox$ (Info AS InputType, Text AS STRING)
DIM kb AS STRING
DIM Cursor AS INTEGER
DIM Begin AS INTEGER
DIM MaxWidth AS INTEGER
DIM OverWrite AS INTEGER
' consider any optional text inside the box
tLen = 1
tLen = tLen + LEN(RTRIM$(Info.Text))
IF tLen > 1 THEN
COLOR 0, 7
LOCATE Info.Corner.T + 1, Info.Corner.L + 1, 1
PRINT RTRIM$(Info.Text);
tLen = tLen + 1
END IF
' find the max width of the input field
MaxWidth = Info.Corner.R - Info.Corner.L - tLen
cTop = 6
Cursor = 1
Begin = 1
' place default text in the input field
IF Text > "" THEN
Cursor = LEN(Text$) + 1
IF Cursor > MaxWidth THEN Begin = Cursor - MaxWidth + 1
COLOR 7, 0
LOCATE Info.Corner.T + 1, Info.Corner.L + tLen, 1, cTop, 7
PRINT MID$(Text$, Begin, MaxWidth);
spa = MaxWidth - (LEN(Text$) - Begin) - 1
Reject = TRUE
END IF
COLOR 0, 7
DO
LOCATE Info.Corner.T + 1, Info.Corner.L + (Cursor - Begin) + tLen, 1, cTop, 7
DO
kb$ = INKEY$
LOOP WHILE kb$ = ""
IF LEFT$(kb$, 1) = CHR$(0) THEN
SELECT CASE RIGHT$(kb$, 1)
CASE CHR$(cstLEFT)
IF Cursor > 1 THEN Cursor = Cursor - 1
IF Cursor < Begin THEN Begin = Begin - 1
Reject = FALSE
CASE CHR$(cstRIGHT)
IF Cursor < Info.Maxlen THEN Cursor = Cursor + 1
IF Cursor > LEN(Text$) THEN Cursor = LEN(Text$) + 1
IF Cursor - Begin >= MaxWidth THEN Begin = Begin + 1
Reject = FALSE
CASE CHR$(cstHOME)
Cursor = 1
Begin = 1
Reject = FALSE
CASE CHR$(cstEND)
Cursor = LEN(Text$) + 1
IF Cursor - Begin > MaxWidth THEN Begin = Cursor - MaxWidth + 1
Reject = FALSE
CASE CHR$(cstDELETE)
IF Reject THEN
Text$ = ""
Begin = 1
Cursor = 1
ELSE
Text$ = LEFT$(Text$, Cursor - 1) + MID$(Text$, Cursor + 1)
END IF
Reject = FALSE
CASE CHR$(cstINSERT)
OverWrite = NOT OverWrite
cTop = cTop XOR 7
END SELECT
ELSE
SELECT CASE kb$
CASE CHR$(cstENTER), CHR$(cstTAB), CHR$(cstESC)
EXIT DO
CASE CHR$(cstBKSP)
IF Reject THEN
Text$ = ""
Begin = 1
Cursor = 1
ELSE
IF Cursor = 2 THEN
Text$ = MID$(Text$, Cursor)
ELSEIF Cursor > 2 THEN
Text$ = LEFT$(Text$, Cursor - 2) + MID$(Text$, Cursor)
END IF
Cursor = Cursor - 1
IF Cursor = 0 THEN Cursor = 1
IF Cursor < Begin THEN Begin = Cursor
END IF
Reject = FALSE
CASE ELSE
IF Reject THEN
Text$ = ""
Begin = 1
Cursor = 1
END IF
IF Cursor <= Info.Maxlen THEN
IF NOT OverWrite THEN
Text$ = LEFT$(Text$, Cursor - 1) + kb$ + MID$(Text$, Cursor)
ELSE
IF Cursor > LEN(Text$) AND LEN(Text$) < Info.Maxlen THEN Text$ = Text$ + " "
MID$(Text$, Cursor, 1) = kb$
END IF
IF Cursor <= Info.Maxlen THEN Cursor = Cursor + 1
IF Cursor - Begin + 1 > MaxWidth THEN Begin = Begin + 1
END IF
IF LEN(Text$) > Info.Maxlen THEN Text$ = LEFT$(Text$, Info.Maxlen)
Reject = FALSE
END SELECT
END IF
LOCATE Info.Corner.T + 1, Info.Corner.L + tLen
PRINT MID$(Text$, Begin, MaxWidth);
spa% = MaxWidth - (LEN(Text$) - Begin) - 1
PRINT SPC(spa%);
LOOP UNTIL kb$ = CHR$(cstESC)
Main.InputBox$ = Text$
END FUNCTION
FUNCTION Main.List% (Array() AS ListBoxItemType, Info AS ListBoxGroupType)
DIM kb AS STRING
IF Info.ItemCount < 1 THEN EXIT FUNCTION
kb = ""
Main.List = FALSE
DO
' remember the current item so it may not have to be redrawn
Last = Info.ItemCurrent
CALL lstPrintItem(Array(Info.ItemCurrent), Info, TRUE)
DO
kb$ = INKEY$
LOOP WHILE kb$ = ""
IF LEFT$(kb$, 1) = CHR$(0) THEN
CALL lstPrintItem(Array(Info.ItemCurrent), Info, FALSE)
SELECT CASE RIGHT$(kb$, 1)
CASE CHR$(cstHOME)
Info.ItemTop = 1
Info.ItemCurrent = 1
Info.ColTop = 1
Info.ColCurrent = 1
IF Info.ItemCurrent <> Last THEN CALL lstShow(Array(), Info, TRUE)
CASE CHR$(cstEND)
Info.ItemCurrent = Info.ItemCount
Info.ColCurrent = Info.ColCount
IF Info.ColMulti THEN
Info.ColTop = Info.ColCount - Info.ColShow + 1
Info.ItemTop = (Info.ColCount - Info.ColShow) * Info.MaxSet
CALL lstShow(Array(), Info, TRUE)
ELSE
Info.ItemTop = Info.ItemCount - Info.MaxSet + 1
END IF
IF Info.ItemCurrent <> Last THEN CALL lstShow(Array(), Info, TRUE)
CASE CHR$(cstUP)
IF Info.ItemCurrent > 1 THEN Info.ItemCurrent = Info.ItemCurrent - 1
IF Info.ColMulti THEN
IF Info.ItemCurrent = (Info.ColCurrent - 1) * Info.MaxSet THEN
IF Info.ColCurrent > 1 THEN
Info.ColCurrent = Info.ColCurrent - 1
Info.ItemCurrent = Info.ColCurrent * Info.MaxSet
IF Info.ColCurrent < Info.ColTop THEN
Info.ColTop = Info.ColTop - 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
END IF
ELSE
IF Info.ItemCurrent < Info.ItemTop AND Info.ItemTop > 1 THEN
Info.ItemTop = Info.ItemTop - 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
CASE CHR$(cstDOWN)
IF Info.ItemCurrent < Info.ItemCount THEN Info.ItemCurrent = Info.ItemCurrent + 1
IF Info.ColMulti THEN
IF Info.ItemCurrent > Info.ColCurrent * Info.MaxSet THEN
' find the next item
IF Info.ItemCurrent > Info.ItemCount THEN Info.ItemCurrent = Info.ItemCount
Info.ItemTop = Info.ItemTop + Info.MaxSet
IF Info.ItemTop > Info.ItemCount THEN Info.ItemTop = Info.ItemCount - (Info.ItemCount \ Info.ColCount - 1)
' find the proper row
IF Info.ColCurrent < Info.ColCount THEN
Info.ColCurrent = Info.ColCurrent + 1
IF Info.ColCurrent > Info.ColTop + Info.ColShow - 1 THEN
Info.ColTop = Info.ColTop + 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
END IF
ELSE
IF Info.ItemCurrent > Info.ItemTop + Info.MaxSet - 1 THEN
Info.ItemTop = Info.ItemTop + 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
CASE CHR$(cstLEFT)
IF Info.ColMulti THEN
Info.ItemCurrent = Info.ItemCurrent - Info.MaxSet
IF Info.ItemCurrent < 1 THEN Info.ItemCurrent = 1
IF Info.ItemCurrent < Info.ItemTop THEN
Info.ItemTop = Info.ItemTop - Info.MaxSet
IF Info.ItemTop < 1 THEN Info.ItemTop = 1
END IF
IF Info.ColCurrent > 1 THEN
Info.ColCurrent = Info.ColCurrent - 1
IF Info.ColCurrent < Info.ColTop THEN
Info.ColTop = Info.ColTop - 1
IF Info.ColTop < 1 THEN Info.ColTop = 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
ELSE
IF Info.ItemCurrent > 1 THEN Info.ItemCurrent = Info.ItemCurrent - 1
IF Info.ItemCurrent < Info.ItemTop AND Info.ItemTop > 1 THEN
Info.ItemTop = Info.ItemTop - 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
CASE CHR$(cstRIGHT)
IF Info.ColMulti THEN
' find the next item
Info.ItemCurrent = Info.ItemCurrent + Info.MaxSet
IF Info.ItemCurrent > Info.ItemCount THEN Info.ItemCurrent = Info.ItemCount
' find the proper column
IF Info.ColCurrent < Info.ColCount THEN
Info.ColCurrent = Info.ColCurrent + 1
IF Info.ColCurrent = Info.ColTop + Info.ColShow THEN Info.ColTop = Info.ColTop + 1
CALL lstShow(Array(), Info, TRUE)
END IF
ELSE
IF Info.ItemCurrent < Info.ItemCount THEN Info.ItemCurrent = Info.ItemCurrent + 1
IF Info.ItemCurrent > Info.ItemTop + Info.MaxSet - 1 THEN
Info.ItemTop = Info.ItemTop + 1
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
CASE CHR$(cstPGUP)
IF Info.ColMulti THEN
Info.ItemCurrent = Info.ItemCurrent - Info.MaxSet * Info.ColShow
IF Info.ItemCurrent < 1 THEN Info.ItemCurrent = 1
IF Info.ItemCurrent < Info.ItemTop THEN
Info.ItemTop = Info.ItemTop - Info.MaxSet * Info.ColShow
IF Info.ItemTop < 1 THEN Info.ItemTop = 1
END IF
IF Info.ColCurrent > 1 THEN
Info.ColCurrent = Info.ColCurrent - Info.ColShow
IF Info.ColCurrent < 1 THEN Info.ColCurrent = 1
Info.ColTop = Info.ColTop - Info.ColShow
IF Info.ColTop < 1 THEN Info.ColTop = 1
CALL lstShow(Array(), Info, TRUE)
END IF
ELSE
Info.ItemCurrent = Info.ItemCurrent - Info.MaxSet
IF Info.ItemCurrent < 1 THEN Info.ItemCurrent = 1
Info.ItemTop = Info.ItemTop - Info.MaxSet
IF Info.ItemTop < 1 THEN Info.ItemTop = 1
CALL lstShow(Array(), Info, TRUE)
END IF
CASE CHR$(cstPGDN)
IF Info.ColMulti THEN
' find the next item
Info.ItemCurrent = Info.ItemCurrent + Info.MaxSet * Info.ColShow
IF Info.ItemCurrent > Info.ItemCount THEN Info.ItemCurrent = Info.ItemCount
' find the proper column
IF Info.ColCurrent < Info.ColCount THEN
Info.ColCurrent = Info.ColCurrent + Info.ColShow
IF Info.ColCurrent > Info.ColCount THEN Info.ColCurrent = Info.ColCount
Info.ColTop = Info.ColCurrent - Info.ColShow + 1
CALL lstShow(Array(), Info, TRUE)
END IF
ELSE
IF Info.ItemCurrent < Info.ItemCount THEN Info.ItemCurrent = Info.ItemCurrent + Info.MaxSet
IF Info.ItemCurrent > Info.ItemTop + Info.MaxSet - 1 THEN
Info.ItemTop = Info.ItemTop + Info.MaxSet
CALL lstShow(Array(), Info, TRUE)
END IF
END IF
END SELECT
ELSE
IF kb$ = CHR$(cstENTER) OR kb$ = CHR$(cstTAB) THEN
Main.List = Info.ItemCurrent
EXIT DO
ELSEIF kb$ = CHR$(cstSPACE) THEN
IF Info.ListType = cstCHECK OR Array(Info.ItemCurrent).ListType = cstCHECK THEN
Array(Info.ItemCurrent).ItemCurrent = NOT Array(Info.ItemCurrent).ItemCurrent
ELSE
Main.List = Info.ItemCurrent
EXIT DO
END IF
ELSEIF lstHotKey(Array(), Info, kb$) THEN
Main.List = Info.ItemCurrent
EXIT DO
END IF
END IF
LOOP UNTIL kb$ = CHR$(cstESC)
END FUNCTION
' main routine for the 'MENUBAR' element
'
FUNCTION Main.Menu% (Info AS MenuGroupType, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType)
DIM KeyHit AS STRING
DIM Idx AS INTEGER
DIM State AS INTEGER
DIM Selected AS INTEGER
DIM x AS INTEGER
DIM ptr AS INTEGER
' save screen and set initial values
PCOPY 0, 1
Idx = 1
ptr = 1
State = LOW
Selected = FALSE
' save cursor position and turn cursor off
CALL scrCursorOn(FALSE)
DO
DO
KeyHit$ = INKEY$
IF kbALT THEN EXIT DO
LOOP WHILE KeyHit$ = ""
' check for shortcut keys
IF LEN(KeyHit$) = 1 THEN KeyHit$ = mnuHotKey(Idx, ptr, State, KeyHit$, MenuIdx(), MenuItem(), Info)
' check for ALT key pressed
IF kbALT THEN
' user pressed ALT to enter menu
IF State = LOW THEN
' turn on index short keys
FOR x = 1 TO Info.Idx
CALL mnuPrintItem(x, ROOT, LOMED, MenuIdx(), MenuItem())
NEXT x
END IF
' wait for user to release ALT key
DO WHILE kbALT
' check for ALTed shortcut keys
KeyHit$ = INKEY$
IF LEN(KeyHit$) = 1 THEN
State = LOMED
KeyHit$ = mnuHotKey(Idx, ptr, State, KeyHit$, MenuIdx(), MenuItem(), Info)
END IF
LOOP
' user pressed ALT to exit menu
IF State = HIMED THEN
KeyHit$ = CHR$(cstESC)
ELSEIF State = HI THEN
' turn on index short keys
PCOPY 1, 0
FOR x = 1 TO Info.Idx
CALL mnuPrintItem(x, ROOT, LOMED, MenuIdx(), MenuItem())
NEXT x
END IF
IF State <> HIMED THEN
' turn on initial index
State = HIMED
CALL mnuPrintItem(Idx, ROOT, HIMED, MenuIdx(), MenuItem())
END IF
END IF
' check for regular keys
IF LEFT$(KeyHit$, 1) = CHR$(0) THEN
SELECT CASE RIGHT$(KeyHit$, 1)
CASE CHR$(cstUP)
CALL mnuPrintItem(Idx, ptr, LOMED, MenuIdx(), MenuItem())
IF State = HIMED THEN
KeyHit$ = CHR$(cstENTER)
ELSE
ptr = ptr - 1
IF ptr < MenuIdx(Idx).IdxStart THEN ptr = MenuIdx(Idx).IdxStart + MenuIdx(Idx).MaxItem - 1
IF MenuItem(ptr).ShortKey = 0 THEN ptr = ptr - 1
END IF
CALL mnuPrintItem(Idx, ptr, HIMED, MenuIdx(), MenuItem())
CASE CHR$(cstDOWN)
CALL mnuPrintItem(Idx, ptr, LOMED, MenuIdx(), MenuItem())
IF State = HIMED THEN
KeyHit$ = CHR$(cstENTER)
ELSE
ptr = ptr + 1
IF ptr > MenuIdx(Idx).IdxStart + MenuIdx(Idx).MaxItem - 1 THEN ptr = MenuIdx(Idx).IdxStart
IF MenuItem(ptr).ShortKey = 0 THEN ptr = ptr + 1
END IF
CALL mnuPrintItem(Idx, ptr, HIMED, MenuIdx(), MenuItem())
CASE CHR$(cstLEFT)
IF State = HIMED THEN
CALL mnuPrintItem(Idx, ROOT, LOMED, MenuIdx(), MenuItem())
Idx = Idx - 1
IF Idx = 0 THEN Idx = Info.Idx
CALL mnuPrintItem(Idx, ROOT, HIMED, MenuIdx(), MenuItem())
ELSEIF State = HI THEN
Idx = Idx - 1
IF Idx = 0 THEN Idx = Info.Idx
CALL mnuPrintMenu(Idx, MenuIdx(), MenuItem())
END IF
ptr = MenuIdx(Idx).IdxStart
CASE CHR$(cstRIGHT)
IF State = HIMED THEN
CALL mnuPrintItem(Idx, ROOT, LOMED, MenuIdx(), MenuItem())
Idx = Idx + 1
IF Idx > Info.Idx THEN Idx = 1
CALL mnuPrintItem(Idx, ROOT, HIMED, MenuIdx(), MenuItem())
ELSE
Idx = Idx + 1
IF Idx > Info.Idx THEN Idx = 1
CALL mnuPrintMenu(Idx, MenuIdx(), MenuItem())
END IF
ptr = MenuIdx(Idx).IdxStart
END SELECT
ELSEIF KeyHit$ = CHR$(cstESC) THEN
State = HI
KeyHit$ = CHR$(cstENTER)
Main.Menu = 0
Selected = TRUE
END IF
' ENTER
IF KeyHit$ = CHR$(cstENTER) THEN
' made a selection
IF State = HI THEN
IF NOT MenuItem(ptr).Disabled AND NOT MenuIdx(Idx).Disabled THEN
Main.Menu = ptr
Selected = TRUE
END IF
' turn on menu
ELSEIF State = HIMED THEN
State = HI
CALL mnuPrintMenu(Idx, MenuIdx(), MenuItem())
ptr = MenuIdx(Idx).IdxStart
END IF
' if user is holding ALT, wait for release
WHILE GetKey$ = CHR$(cstALT): WEND
END IF
LOOP UNTIL Selected%
' restore initial screen and cursor
PCOPY 1, 0
CALL scrCursorOn(TRUE)
END FUNCTION
' main routine for the 'TEXTBOX' element
'
SUB Main.TextBox (Info AS TextBoxType, TBoxPtr() AS INTEGER, TBoxArr() AS STRING, TBoxTxt AS STRING)
IF Info.Top < 1 THEN Info.Top = 1
CALL txtFill(Info, TBoxTxt$, TBoxPtr(), TBoxArr())
IF Info.Cursor < 1 THEN Info.Cursor = 1
IF Info.Col < 1 THEN Info.Col = 1
IF Info.Row < 1 THEN Info.Row = 1
TBoxHeight = Info.Corner.B - Info.Corner.T - 2
DO
' print status bar
Inf$ = " " + LTRIM$(STR$(Info.Row)) + " : " + LTRIM$(STR$(Info.Col)) + " "
LOCATE Info.Corner.B, Info.Corner.R - 13
PRINT STRING$(12 - LEN(Inf$), CHR$(196)); Inf$;
' determine the height of the Info.Cursor
IF Info.Insert THEN
LOCATE Info.Corner.T + Info.Row - Info.Top + 1, Info.Corner.L + Info.Col, 1, 6, 7
ELSE
LOCATE Info.Corner.T + Info.Row - Info.Top + 1, Info.Corner.L + Info.Col, 1, 1, 7
END IF
DO
kb$ = INKEY$
WHILE kbCTRL
IF kbScan(&H47) THEN ' CTRL+HOME
Info.Top = 1
Info.Row = 1
Info.Cursor = 1
Info.Col = 1
CALL txtPrintItem(Info, TBoxPtr(), TBoxArr())
ELSEIF kbScan(&H4F) THEN ' CTRL+END
Info.Top = Info.MaxLines - TBoxHeight
IF Info.Top < 1 THEN Info.Top = 1
Info.Row = Info.MaxLines
Info.Cursor = LEN(TBoxTxt)
Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
CALL txtPrintItem(Info, TBoxPtr(), TBoxArr())
END IF
IF Info.Insert THEN
LOCATE Info.Corner.T + Info.Row - Info.Top + 1, Info.Corner.L + Info.Col, 1, 6, 7
ELSE
LOCATE Info.Corner.T + Info.Row - Info.Top + 1, Info.Corner.L + Info.Col, 1, 1, 7
END IF
WEND
IF kbALT THEN EXIT SUB
LOOP WHILE kb$ = ""
OldInfo.Top = Info.Top
IF LEFT$(kb$, 1) = CHR$(0) THEN
SELECT CASE RIGHT$(kb$, 1)
CASE CHR$(cstLEFT)
IF Info.Cursor > 1 THEN
Info.Cursor = Info.Cursor - 1
Info.Col = Info.Col - 1
IF Info.Col < 1 THEN
IF Info.Row > Info.Top THEN
Info.Row = Info.Row - 1
Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
ELSEIF Info.Top > 1 THEN
Info.Top = Info.Top - 1
Info.Row = Info.Row - 1
Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
ELSE
Info.Col = 1
END IF
END IF
END IF
CASE CHR$(cstRIGHT)
IF Info.Cursor < LEN(TBoxTxt$) THEN
Info.Cursor = Info.Cursor + 1
Info.Col = Info.Col + 1
IF Info.Col > txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt) THEN
Info.Col = 1
Info.Row = Info.Row + 1
END IF
IF Info.Row - Info.Top + 1 > Info.Corner.B - Info.Corner.T - 1 THEN Info.Top = Info.Top + 1
END IF
CASE CHR$(cstUP)
IF Info.Row > Info.Top THEN
Info.Row = Info.Row - 1
IF Info.Col > txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt) THEN Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
ELSEIF Info.Top > 1 AND Info.MaxLines > 1 THEN
Info.Top = Info.Top - 1
Info.Row = Info.Row - 1
IF Info.Row < 1 THEN Info.Row = 1
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
END IF
CASE CHR$(cstDOWN)
IF Info.Row < Info.MaxLines THEN
Info.Row = Info.Row + 1
IF Info.Col > txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt) THEN Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
IF Info.Row - Info.Top + 1 > Info.Corner.B - Info.Corner.T - 1 THEN Info.Top = Info.Top + 1
END IF
CASE CHR$(cstHOME)
Info.Cursor = TBoxPtr(Info.Row)
Info.Col = 1
CASE CHR$(cstEND)
Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
CASE CHR$(cstINSERT)
Info.Insert = NOT Info.Insert
CASE CHR$(cstDELETE)
TBoxTxt$ = LEFT$(TBoxTxt$, Info.Cursor - 1) + MID$(TBoxTxt$, Info.Cursor + 1)
CALL txtFill(Info, TBoxTxt$, TBoxPtr(), TBoxArr())
CASE CHR$(cstPGUP)
Info.Top = Info.Top - TBoxHeight
Info.Row = Info.Row - TBoxHeight
IF Info.Top < 1 THEN Info.Top = 1
IF Info.Row < 1 THEN Info.Row = 1
IF Info.Col > txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt) THEN Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
CASE CHR$(cstPGDN)
Info.Top = Info.Top + TBoxHeight
Info.Row = Info.Row + TBoxHeight
IF Info.Row > Info.MaxLines THEN Info.Row = Info.MaxLines
IF Info.Top + TBoxHeight > Info.MaxLines THEN Info.Top = Info.MaxLines - TBoxHeight
IF Info.Col > txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt) THEN Info.Col = txtWidth(Info.Row, Info, TBoxPtr(), TBoxTxt)
Info.Cursor = TBoxPtr(Info.Row) + Info.Col - 1
END SELECT
ELSEIF kb$ = CHR$(cstBKSP) THEN
IF Info.Cursor > 1 THEN
TBoxTxt$ = LEFT$(TBoxTxt$, Info.Cursor - 2) + MID$(TBoxTxt$, Info.Cursor)
Info.Cursor = Info.Cursor - 1
CALL txtFill(Info, TBoxTxt$, TBoxPtr(), TBoxArr())
IF Info.Col < 1 THEN END
END IF
ELSEIF kb$ = CHR$(cstTAB) THEN
TBoxTxt$ = LEFT$(TBoxTxt$, Info.Cursor - 1) + SPACE$(3) + MID$(TBoxTxt$, Info.Cursor)
Info.Cursor = Info.Cursor + 3
CALL txtFill(Info, TBoxTxt$, TBoxPtr(), TBoxArr())
ELSEIF kb$ <> CHR$(cstESC) THEN
' place new character in the string
IF Info.Insert OR kb$ = CHR$(cstENTER) THEN
TBoxTxt$ = LEFT$(TBoxTxt$, Info.Cursor - 1) + kb$ + MID$(TBoxTxt$, Info.Cursor)
ELSE
MID$(TBoxTxt$, Info.Cursor, 1) = kb$
END IF
Info.Cursor = Info.Cursor + 1
CALL txtFill(Info, TBoxTxt$, TBoxPtr(), TBoxArr())
END IF
' scroll the text
IF Info.Top <> OldInfo.Top THEN CALL txtPrintItem(Info, TBoxPtr(), TBoxArr())
LOOP UNTIL kb$ = CHR$(cstESC)
END SUB
' scans the menu for a short cut key
'
FUNCTION mnuHotKey$ (Idx, ptr, State, KeyHit$, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType, Info AS MenuGroupType)
DIM x AS INTEGER
' assign default value
mnuHotKey = KeyHit$
' scan for menu index keys
IF State = HIMED OR State = LOMED THEN
FOR x = 1 TO Info.Idx
IF LCASE$(KeyHit$) = LCASE$(MID$(MenuIdx(x).Label, MenuIdx(x).ShortKey, 1)) THEN
Idx = x
mnuHotKey = CHR$(13)
EXIT FOR
END IF
NEXT x
' scan for menu item keys
ELSEIF State = HI THEN
FOR x = MenuIdx(Idx).IdxStart TO MenuIdx(Idx).IdxStart + MenuIdx(Idx).MaxItem - 1
IF MenuItem(x).ShortKey > 0 THEN
IF LCASE$(KeyHit$) = LCASE$(MID$(MenuItem(x).Label, MenuItem(x).ShortKey, 1)) THEN
CALL mnuPrintItem(Idx, ptr, LOMED, MenuIdx(), MenuItem())
ptr = x
CALL mnuPrintItem(Idx, ptr, HIMED, MenuIdx(), MenuItem())
mnuHotKey = CHR$(13)
EXIT FOR
END IF
END IF
NEXT x
END IF
END FUNCTION
' loads the menu from DATA into array
'
SUB mnuLoad (Info AS MenuGroupType, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType)
DIM Label AS STRING
DIM Alignment AS STRING * 1
DIM Idx AS INTEGER
DIM IdxColumnR AS INTEGER
DIM IdxColumnL AS INTEGER
DIM x AS INTEGER
DIM ptr AS INTEGER
' redimension arrays
REDIM MenuIdx(1 TO Info.Idx) AS MenuIdxType
REDIM MenuItem(1 TO Info.Item) AS MenuItemType
' initial setting for index alignment
IdxColumnL = 3
IdxColumnR = 80
' open the data file
IF Info.FileName > "" THEN
OPEN Info.FileName FOR INPUT AS #1
INPUT #1, Label
ELSE
READ Label
END IF
DO UNTIL Label = "/EOF"
IF LEFT$(Label, 1) = "/" OR LEFT$(Label, 1) = "\" THEN
Alignment = LEFT$(Label, 1)
Idx = Idx + 1
' find shortcut key
FOR x = 1 TO LEN(Label)
IF MID$(Label, x, 1) = "&" THEN
MenuIdx(Idx).ShortKey = x - 1
EXIT FOR
END IF
NEXT x
' assign label and increase counter
Label = LEFT$(Label, x - 1) + MID$(Label, x + 1)
Label = MID$(Label, 2)
MenuIdx(Idx).Label = Label
' assign menu IdxColumn
IF Alignment = "/" THEN
MenuIdx(Idx).IdxColumn = IdxColumnL
IdxColumnL = IdxColumnL + LEN(Label) + 2
ELSE
IdxColumnR = IdxColumnR - LEN(Label) - 2
MenuIdx(Idx).IdxColumn = IdxColumnR
END IF
' read item
ELSEIF LEFT$(Label, 3) = "..." THEN
' move index pointer
ptr = ptr + 1
IF MenuIdx(Idx).IdxStart = 0 THEN MenuIdx(Idx).IdxStart = ptr
' increment max items count
MenuIdx(Idx).MaxItem = MenuIdx(Idx).MaxItem + 1
' find shortcut key
x = INSTR(Label, "&")
IF x > 0 THEN MenuItem(ptr).ShortKey = x - 3 ELSE x = LEN(Label)
' clean up label
Label = LEFT$(Label, x - 1) + MID$(Label, x + 1)
Label = MID$(Label, 4)
MenuItem(ptr).Label = Label
' set max length
IF LEN(Label) > MenuIdx(Idx).MaxWidth THEN MenuIdx(Idx).MaxWidth = LEN(Label)
' set items box starting column
IF MenuIdx(Idx).IdxColumn + MenuIdx(Idx).MaxWidth > 76 THEN
MenuIdx(Idx).StartCol = 76 - MenuIdx(Idx).MaxWidth
ELSE
MenuIdx(Idx).StartCol = MenuIdx(Idx).IdxColumn
END IF
END IF
IF Info.FileName > "" THEN
INPUT #1, Label
ELSE
READ Label
END IF
LOOP
CLOSE #1
END SUB
' finds the max required array bounds of the menu
'
SUB mnuMaxData (Info AS MenuGroupType)
DIM Label AS STRING
DIM FileNum AS INTEGER
IF Info.FileName > "" THEN
FileNum = FREEFILE
OPEN Info.FileName FOR INPUT AS FileNum
INPUT #1, Label
ELSE
READ Label
END IF
DO UNTIL Label = "/EOF"
IF LEFT$(Label, 1) = "/" OR LEFT$(Label, 1) = "\" THEN
Info.Idx = Info.Idx + 1
ELSEIF LEFT$(Label, 3) = "..." THEN
Info.Item = Info.Item + 1
END IF
IF Info.FileName > "" THEN
INPUT #1, Label
ELSE
READ Label
END IF
LOOP
IF Info.FileName > "" THEN CLOSE FileNum
END SUB
' prints menu index and item labels
'
SUB mnuPrintItem (Idx, ptr, State, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType)
DIM Fore AS INTEGER
DIM Back AS INTEGER
DIM Item AS INTEGER
Fore = 0
Back = 7
' account for menu being disabled
IF MenuIdx(Idx).Disabled THEN Fore = 8
IF ptr > ROOT THEN IF MenuItem(ptr).Disabled THEN Fore = 8
' select proper colors
IF State > LOMED THEN SWAP Fore, Back
COLOR Fore, Back
' print item
IF ptr = ROOT THEN
Item = 0
' print label
LOCATE Item + 1, MenuIdx(Idx).IdxColumn
PRINT " "; RTRIM$(MenuIdx(Idx).Label); " ";
' set cursor for short key
LOCATE Item + 1, MenuIdx(Idx).IdxColumn + MenuIdx(Idx).ShortKey
ELSE
Item = ptr - MenuIdx(Idx).IdxStart + 1
' print label
LOCATE Item + 2, MenuIdx(Idx).StartCol
IF MenuItem(ptr).ShortKey = BREAK THEN
LOCATE , POS(0) - 1
PRINT CHR$(195); STRING$(MenuIdx(Idx).MaxWidth + 2, CHR$(196)); CHR$(180);
ELSE
PRINT " "; LEFT$(MenuItem(ptr).Label, MenuIdx(Idx).MaxWidth); " ";
END IF
' print bullet
IF MenuItem(ptr).Bullet THEN
LOCATE Item + 2, MenuIdx(Idx).StartCol
CALL scrPrint(7, Fore, Back)
END IF
' set cursor for short key
LOCATE Item + 2, MenuIdx(Idx).StartCol + MenuItem(ptr).ShortKey
END IF
' select color for short key (short key only on in MED states)
SELECT CASE State
CASE LOMED: COLOR 15, 7
CASE HIMED: COLOR 15, 0
END SELECT
' print short key if not disabled
IF NOT MenuIdx(Idx).Disabled THEN
IF ptr = ROOT THEN
PRINT MID$(MenuIdx(Idx).Label, MenuIdx(Idx).ShortKey, 1);
ELSEIF MenuItem(ptr).ShortKey <> BREAK AND NOT MenuItem(ptr).Disabled THEN
PRINT MID$(MenuItem(ptr).Label, MenuItem(ptr).ShortKey, 1);
END IF
END IF
END SUB
' prints specified menu
'
SUB mnuPrintMenu (Idx, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType)
DIM x AS INTEGER
' turn off old menu
PCOPY 1, 0
' print box
CALL scrBox(2, MenuIdx(Idx).StartCol - 1, MenuIdx(Idx).MaxItem + 3, MenuIdx(Idx).StartCol + MenuIdx(Idx).MaxWidth + 2, TRUE)
' fill box with items
FOR x = MenuIdx(Idx).IdxStart TO MenuIdx(Idx).IdxStart + MenuIdx(Idx).MaxItem - 1
CALL mnuPrintItem(Idx, x, LOMED, MenuIdx(), MenuItem())
NEXT x
' highlight index
CALL mnuPrintItem(Idx, ROOT, HI, MenuIdx(), MenuItem())
' highlight initial item
CALL mnuPrintItem(Idx, MenuIdx(Idx).IdxStart, HIMED, MenuIdx(), MenuItem())
' "��ó��ڿ"
END SUB
' prints menu index on top line
'
SUB mnuShow (Info AS MenuGroupType, MenuIdx() AS MenuIdxType, MenuItem() AS MenuItemType)
DIM x AS INTEGER
' print white line on top of screen
COLOR 0, 7
LOCATE 1, 1: PRINT SPACE$(80);
' print the menu index values
FOR x = 1 TO Info.Idx
CALL mnuPrintItem(x, ROOT, LOW, MenuIdx(), MenuItem())
NEXT x
END SUB
' determines if a fixed length string has any data
'
FUNCTION Null (Text AS STRING)
DIM x AS INTEGER
Null = TRUE
FOR x = 1 TO LEN(Text)
IF MID$(Text, x, 1) <> CHR$(0) AND MID$(Text, x, 1) <> CHR$(32) THEN
Null = FALSE
EXIT FOR
END IF
NEXT x
END FUNCTION
' opens a pop-up alert box and awaits input
'
FUNCTION scrAlert$ (Title AS STRING, Text AS STRING, MaxWidth AS INTEGER, Height AS INTEGER)
DIM aData AS TextBoxType
DIM aValues(0) AS INTEGER
DIM aStrings(0) AS STRING
aData.Corner.T = 10
aData.Corner.L = 25
aData.Corner.R = 55
aData.Corner.B = 14
aData.Top = 1
aData.Cursor = 1
aData.Shadow = TRUE
IF MaxWidth > 0 THEN
aData.Corner.L = 40 - MaxWidth \ 2
aData.Corner.R = 40 + MaxWidth \ 2
END IF
IF Height > 0 THEN
aData.Corner.T = 11 - (Height \ 2)
aData.Corner.B = aData.Corner.T + Height + 1
END IF
CALL scrBox(aData.Corner.T, aData.Corner.L, aData.Corner.B, aData.Corner.R, TRUE)
LOCATE aData.Corner.T, aData.Corner.L + (aData.Corner.R - aData.Corner.L) \ 2 - LEN(Title) \ 2 - 2
COLOR 0, 7
PRINT " "; RTRIM$(Title); " ";
CALL txtFill(aData, " " + Text, aValues(), aStrings())
Alert$ = INPUT$(1)
COLOR 7, 0
END FUNCTION
' draws a single line box at specified coordinates, with shadowing
'
SUB scrBox (Row1%, Col1%, Row2%, Col2%, Shadow%)
DIM x AS INTEGER
' print box
COLOR 0, 7
LOCATE Row1, Col1
PRINT CHR$(218); STRING$(Col2 - Col1 - 1, CHR$(196)); CHR$(191);
FOR x = Row1 TO Row2 - 1
COLOR 0, 7
LOCATE x + 1, Col1
PRINT CHR$(179); SPACE$(Col2 - Col1 - 1); CHR$(179);
' print shadowing
IF Shadow% THEN
COLOR 8, 0
LOCATE x + 1, Col2 + 1: PRINT CHR$(SCREEN(x + 1, Col2 + 1));
PRINT CHR$(SCREEN(x + 1, Col2 + 2));
END IF
NEXT x
COLOR 0, 7
LOCATE Row2, Col1
PRINT CHR$(192); STRING$(Col2 - Col1 - 1, CHR$(196)); CHR$(217);
' print shadowing
IF Shadow% THEN
COLOR 8, 0
FOR x = Col1 TO Col2
LOCATE Row2 + 1, x + 2
PRINT CHR$(SCREEN(Row2 + 1, x + 2));
NEXT x
COLOR 0, 7
END IF
END SUB
' toggles the cursor while saving it's position and height
'
SUB scrCursorOn (OnOff%) STATIC
DIM CursorLine AS INTEGER
DIM CursorColumn AS INTEGER
DIM Top AS INTEGER
DIM Bottom AS INTEGER
DIM Status AS INTEGER
IF OnOff THEN
' restore cursor settings
LOCATE CursorLine, CursorColumn, Status, Top, Bottom
ELSE
' save cursor settings
Top = PEEK(1121) AND 31
Bottom = PEEK(1120) AND 31
IF PEEK(1121) AND 32 THEN Status = FALSE ELSE Status = 1
CursorLine = CSRLIN
CursorColumn = POS(0)
LOCATE , , 0
END IF
END SUB
' draws a simple background
'
SUB scrCurtain
COLOR 0, 3
FOR x = 1 TO 25
LOCATE x, 1
PRINT STRING$(80, CHR$(176));
NEXT x
END SUB
' puts any ASCII (0-255) character on the screen, with colors
'
SUB scrPrint (ch%, Fore%, Back%)
DEF SEG = 47104
POKE (160 * (CSRLIN - 1) + 2 * (POS(0) - 1)), ch%
POKE (160 * (CSRLIN - 1) + 2 * (POS(0) - 1) + 1), Back% * 16 + Fore%
DEF SEG = 0
END SUB
' word wrap the text and save it in the array
'
SUB txtFill (Info AS TextBoxType, TBoxTxt AS STRING, TBoxPtr() AS INTEGER, TBoxArr() AS STRING)
' find the width of the box
IF Info.Corner.R < 1 THEN Info.Corner.R = 78
IF Info.Corner.L < 1 THEN Info.Corner.L = 1
wi = Info.Corner.R - Info.Corner.L - 1
DIM MaxLines AS INTEGER
MaxLines = 32767 \ wi ' use 32767, max string length
' pad the string with a space and position the cursor appropriately
IF RIGHT$(TBoxTxt$, 1) <> " " THEN TBoxTxt$ = TBoxTxt$ + " "
DIM x AS INTEGER
DIM arTBoxTxt(1 TO MaxLines) AS STRING
DIM arNum(1 TO MaxLines) AS INTEGER
x = 1
cRow = 0
COLOR 0, 7
Info.MaxLines = 0
' process the entire string everytime
DO
' move down the box
Info.MaxLines = Info.MaxLines + 1
' grab a line of TBoxTxt and save the beginning position
kt$ = MID$(TBoxTxt$, x, wi)
arNum(Info.MaxLines) = x
' look for a carraige return
ent = INSTR(kt$, CHR$(cstENTER))
IF ent THEN
IF ent = 1 THEN ' replace just the crlf with a space
kt$ = " "
ELSE
kt$ = LEFT$(kt$, ent - 1) + " " ' chop off the crlf and use a space
END IF
ELSE
' else chop the string until a space is reached
' or keep the whole thing if there is no space
ko$ = kt$
DO UNTIL RIGHT$(kt$, 1) = " "
kt$ = LEFT$(kt$, LEN(kt$) - 1)
LOOP
IF kt$ = "" THEN kt$ = ko$
END IF
' move the counter for the beginning of the next line (string)
x = x + LEN(kt$)
' store the actual string in the array
kt$ = kt$ + SPACE$(wi - LEN(kt$))
arTBoxTxt(Info.MaxLines) = kt$
LOOP UNTIL x > LEN(TBoxTxt$)
' reallocate space and store the data
REDIM TBoxArr(1 TO Info.MaxLines) AS STRING
REDIM TBoxPtr(1 TO Info.MaxLines) AS INTEGER
FOR x = 1 TO Info.MaxLines
TBoxArr(x) = arTBoxTxt(x)
TBoxPtr(x) = arNum(x)
NEXT x
' error checking
IF Info.Top < 1 THEN Info.Top = 1
IF Info.Top > UBOUND(TBoxPtr, 1) THEN Info.Top = UBOUND(TBoxPtr, 1)
IF Info.Cursor > LEN(TBoxTxt$) THEN Info.Cursor = LEN(TBoxTxt$)
IF Info.Cursor < 1 THEN Info.Cursor = 1
IF Info.Cursor < TBoxPtr(Info.Top) THEN
IF Info.Top > 1 THEN Info.Top = Info.Top - 1
Info.Cursor = txtWidth(Info.Top, Info, TBoxPtr(), TBoxTxt)
END IF
IF Info.Row < Info.Top THEN Info.Row = Info.Top
IF Info.Row > Info.MaxLines THEN Info.Row = Info.MaxLines
' reset line counter and Column to find the cursor
x = 0
Info.Col = 0
DO UNTIL Info.Col > 0
x = x + 1
' locate the cursor within this line
FOR p = TBoxPtr(x) TO TBoxPtr(x) + txtWidth(x, Info, TBoxPtr(), TBoxTxt) - 1
IF p = Info.Cursor THEN
Info.Row = x
Info.Col = p - TBoxPtr(x) + 1
EXIT FOR
END IF
NEXT p
LOOP
' account for the scrolling of the text as it is typed in
IF Info.Row - Info.Top > Info.Corner.B - Info.Corner.T - 2 THEN
Info.Top = Info.Top + 1
IF Info.Row < Info.Top THEN
IF Info.Top > 1 THEN Info.Top = Info.Top - 1
ELSE
'Info.Top = 1
END IF
END IF
' print the text in the box
CALL txtPrintItem(Info, TBoxPtr(), TBoxArr())
END SUB
' Opens a text file and loads it to a variable length string
'
FUNCTION txtLoad$ (FileName AS STRING)
OPEN FileName FOR BINARY AS #1
DIM B AS STRING * 1
DIM Text AS STRING
' read every character, ignore line feeds and replace tabs
FOR x% = 1 TO LOF(1)
GET 1, x%, B$
IF B$ = CHR$(9) THEN Text$ = Text$ + SPACE$(3)
IF B$ <> CHR$(10) THEN Text$ = Text$ + B$
NEXT x%
txtLoad$ = Text$
CLOSE #1
END FUNCTION
' print the "wrapped" text in the box
'
SUB txtPrintItem (Info AS TextBoxType, TBoxPtr() AS INTEGER, TBoxArr() AS STRING)
' print the string
COLOR 0, 7
LOCATE , , 0
IF Info.Corner.B < 1 THEN Info.Corner.B = 24
FOR cRow = 1 TO Info.Corner.B - Info.Corner.T - 1
IF Info.Top + cRow - 1 > Info.MaxLines THEN EXIT FOR
LOCATE Info.Corner.T + cRow, Info.Corner.L + 1
PRINT TBoxArr(Info.Top + cRow - 1);
NEXT cRow
' clear the rest of the box
FOR x = Info.Corner.T + cRow TO Info.Corner.B - 1
LOCATE x, Info.Corner.L + 1
PRINT SPACE$(Info.Corner.R - Info.Corner.L - 1);
NEXT x
END SUB
SUB txtSave (Info AS TextBoxType, Text AS STRING)
OPEN Info.FileName FOR BINARY AS #1 LEN = 1
DIM a AS STRING * 1
FOR x% = 1 TO LEN(Text)
a = MID$(Text, x%, 1)
PUT #1, , a
IF a = CHR$(13) THEN
a = CHR$(10)
PUT #1, , a
END IF
NEXT x%
CLOSE
END SUB
' returns the length of text on the specified row in the box
'
FUNCTION txtWidth% (pRow AS INTEGER, Info AS TextBoxType, TBoxPtr() AS INTEGER, TBoxTxt AS STRING)
IF pRow = Info.MaxLines THEN
' return the length of the TBox1Txt minus the beginning of the current row
txtWidth = LEN(TBoxTxt$) - TBoxPtr(pRow) + 1
ELSEIF pRow > 0 THEN
' if there is another line of TBox1Txt then return the value of
' the beginning of the next line minus the beginning of the current line
txtWidth = TBoxPtr(pRow + 1) - TBoxPtr(pRow)
END IF
END FUNCTION
