home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
QBAS
/
PROGEN71.ZIP
/
SAMPLE.BAS
< prev
next >
Wrap
BASIC Source File
|
1991-10-09
|
35KB
|
1,286 lines
'
'ISAM DATABASE Program Generator Version: 7.1
'YOUR PROGRAM.: SAMPLE.BAS
'CREATED ON...: 10-09-1991, 00:05:52
'
'PROGRAM NAME.: SAMPLE
'LIB,QLB CODE.: By: RAYMOND E DIXON 1991
' 11660 VC JOHNSON RD.
' Jacksonville, FL 32218
' (904) 765-4048
'
' Computer generated on.
'
'CPU TYPE.....: 80286
'VIDEO ADAPTER: VGA Color
'ROM BIOS DATE: 04/30/89
'DOS RAM......: 640K
'EXTENDED RAM.: 1024K
'EXPANDED RAM.: 704K
'PRINTERS.....: 2
'RS232........: 4
'FLOPPIES.....: 2
'HARD DRIVES..: 1
'GAME PORTS...: 0
'
'
DEFINT A-Z
DECLARE FUNCTION ISMstatus% (indexnum%)
DECLARE SUB BrowseIRec (nameofindex$,indexnum%,retcode%)
DECLARE SUB mainscreen ()
DECLARE SUB msg.nodata ()
DECLARE SUB PROSAM.scn1 ()
DECLARE SUB ISM (cmd$, indexnum%, retcode%)
' Microsoft BC 7.1, Professional Development System
' Microsoft QBX 7.1, Professional Development System
' Microsoft ISAM 7.1, Professional Development System
' Copyright (C) 1987-1989, Microsoft Corporation
'
' PROGEN71.EXE, PROGEN71.OBJ and files
' PROGEN71.LIB, PROGEN71.QLB and source are
' Copyrighted (C) 1991 by: RAYMOND E DIXON
'
' RAYMOND E DIXON
' 11660 VC JOHNSON RD.
' Jacksonville, Fl. 32218
'
' (904) 765-4048
COMMON SHARED masterfile$,key$
' $INCLUDE: 'PROLIB71.BI'
'define record type here
TYPE RecordType
status as STRING * 1 ' set for record used
LASTNAME AS STRING * 14
FIRSTNAME AS STRING * 14
ADDRESS AS STRING * 34
PHONE1 AS STRING * 7
PHONE2 AS STRING * 10
END TYPE
DIM SHARED TestRecField AS RecordType
DIM SHARED RecField AS RecordType
DIM DispLine$(30)
DIM sf$(20)
fg = white
bg = BLUE
rev = RED
CONST startp = 10
LOCATE 25, 1, 0, 0, 0
COLOR white, BLUE
mainscreen
CONST keyindex = 1
masterfile$ = "SAMPLE.DBF"
NEWFILE:
IF FileExists(masterfile$) = 0 THEN 'If no index then create
OPEN masterfile$ FOR ISAM Recordtype "database" AS keyindex 'Open the data file
Createindex KeyIndex,"IndexLASTNAME",0,"LASTNAME"
Createindex KeyIndex,"IndexFIRSTNAME",0,"FIRSTNAME"
ELSE
OPEN masterfile$ FOR ISAM Recordtype "database" AS keyindex 'Open the data file
END IF
DO
mainscreen
DrawBox 21, 22, 40, 3, 2, black, white, 1, black, white, 1
CenterText "Current Data File :" + masterfile$, 22, black, white
menu$ = "Add a new Record\"
menu$ = menu$ + "Browse/Edit Record's\"
menu$ = menu$ + "Print by Record #\"
menu$ = menu$ + "Delete a Record\"
menu$ = menu$ + "Erase datafile\"
menu$ = menu$ + "System information\"
menu$ = menu$ + "Quit (Return to DOS)\"
mopt = MenuWindow(0, 0, menu$,"Main Menu", black, white, RED, 0)
'Get the option
SELECT CASE mopt 'Select on choice
CASE 1 'Insert a new record
mainscreen
GOSUB InitRecField ' set all fields to null
GOSUB getfieldinfo ' get new record info
CASE 2 'Browse through Records
mainscreen
Imopt = 1
DO
IF ISMstatus(keyindex) = 0 THEN
msg.nodata
EXIT DO
END IF
sf$( 1) = "LASTNAME "
sf$( 2) = "FIRSTNAME "
sf = selbox(sf$(), 2, 2,16, black, white, RED )
SELECT CASE SF
CASE 1
key$= string$(len(RecField.LASTNAME)," ")
setindex KeyIndex, "IndexLASTNAME"
nameofindex$ = "IndexLASTNAME"
CASE 2
key$= string$(len(RecField.FIRSTNAME)," ")
setindex KeyIndex, "IndexFIRSTNAME"
nameofindex$ = "IndexFIRSTNAME"
END SELECT
MOVEFIRST keyindex
BrowseIrec nameofindex$, keyindex, Exitcode
IF Exitcode = 0 THEN
msg.nodata
EXIT DO
END IF
IF Exitcode = 1 THEN
EXIT DO
END IF
WHILE Exitcode = 2
RETRIEVE keyindex, RecField
CALL SAMPLE.scn1
CALL SAMPLE.info1
LOCATE 21, 2
CenterText " ", 21, fg, bg
CenterText "Index in use: " + GETINDEX$(keyindex), 21, fg, bg
BO$ = " Next Prev Search Edit Menu "
Imopt = MenuBar(25, 3, BO$, BLACK, WHITE, RED, Imopt)
IF Imopt = 3 THEN
Exitcode = 0
END IF
IF Imopt = 4 THEN
mopt = 2
GOSUB getfieldinfo
END IF
IF Imopt = 5 THEN
EXIT DO
END IF
IF Imopt = 1 THEN
MOVENEXT keyindex
pnc "░░░░░░░░░░░░░░░░░░░░░░", 24, 11, fg, bg
IF EOF(keyindex) THEN
MOVELAST keyindex
pnc "** At Last record **", 24, 11, fg + 8, bg
END IF
END IF
IF Imopt = 2 THEN
MOVEPREVIOUS keyindex
pnc "░░░░░░░░░░░░░░░░░░░░░░", 24, 11, fg, bg
IF BOF(keyindex) THEN
MOVEFIRST keyindex
pnc "** At First record **", 24, 11, fg + 8, bg
END IF
END IF
RETRIEVE keyindex, RecField
WEND
LOOP
CASE 3 'Print all selected records
DO
IF ISMstatus(keyindex) = 0 THEN
msg.nodata
EXIT DO
END IF
sf$( 1) = "LASTNAME "
captal sf$( 1)
sf$( 2) = "FIRSTNAME "
captal sf$( 2)
sf = selbox(sf$(), 2, 2,16, black, white, RED )
SELECT CASE SF
CASE 1
key$= string$(len(RecField.LASTNAME)," ")
setindex KeyIndex, "IndexLASTNAME"
nameofindex$ = "IndexLASTNAME"
CASE 2
key$= string$(len(RecField.FIRSTNAME)," ")
setindex KeyIndex, "IndexFIRSTNAME"
nameofindex$ = "IndexFIRSTNAME"
END SELECT
DispLine$(1) = "Enter Starting Rec "
DispLine$(2) = "Enter for all"
ans$ = ""
DialogBox DispLine$(), 1, 1, nl, BLACK, WHITE, BLACK, WHITE, 1, ans$,"", Exk
key$ = ans$
DispLine$(1) = "Print to Display or Printer"
Ques$ = "(D/P)"
answ$ = "DdPp"
AskQuestion DispLine$(), 1, 1, 1, BLACK, WHITE, BLACK, WHITE, Ques$, answ$
IF UCASE$(answ$) = "D" THEN
output$ = "CONS:"
CLS
ELSE
output$ = "LPT1:"
IF CheckPrinter <> 1 THEN EXIT DO
END IF
prt = FREEFILE
OPEN output$ FOR OUTPUT AS #prt
WIDTH #prt, 80
'Print the DB in sequence
IF key$ = "" THEN
ISM "F", keyindex, indexrec
ELSE
ISM "EQ", keyindex, indexrec
END IF
IF indexrec THEN
RETRIEVE keyindex, RecField
lp$ = userSformat((RTRIM$(RecField.LASTNAME)),"@@@@@@@@@@@@@@") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.FIRSTNAME)),"@@@@@@@@@@@@@@") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.ADDRESS)),"##################################") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.PHONE1)),"999-9999") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.PHONE2)),"(999) 999-9999") + " "
IF output$ = "LPT1:" THEN
PRINT #prt, LP$
ELSE
PRINT #prt, LEFT$(LP$,79)
END IF
DO WHILE indexrec
ISM "N", keyindex, indexrec
IF indexrec = 1 THEN
RETRIEVE keyindex, RecField
lp$ = userSformat((RTRIM$(RecField.LASTNAME)),"@@@@@@@@@@@@@@") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.FIRSTNAME)),"@@@@@@@@@@@@@@") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.ADDRESS)),"##################################") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.PHONE1)),"999-9999") + " "
lp$ = lp$ + userSformat((RTRIM$(RecField.PHONE2)),"(999) 999-9999") + " "
IF output$ = "LPT1:" THEN
PRINT #prt, LP$
ELSE
PRINT #prt, LEFT$(LP$,79)
END IF
ENDIF
LOOP
IF output$ = "LPT1:" THEN
PRINT #prt, CHR$(12)
ELSE
waitkey 24, fg, bg
END IF
CLOSE #prt
END IF
EXIT DO
LOOP
CASE 4 'Delete a record
DO
IF ISMstatus(keyindex) = 0 THEN
msg.nodata
EXIT DO
END IF
MsgLine "Press for last for next ENTER to select",25 , 0, 7
DrawBox 21, 22, 40, 3, 2, black, white, 1, black, white, 1
CenterText "Select RecField Database", 22, black, white
sf$( 1) = "LASTNAME "
sf$( 2) = "FIRSTNAME "
sf = selbox(sf$(), 2, 2,16, black, white, RED )
SELECT CASE SF
CASE 1
key$= string$(len(RecField.LASTNAME)," ")
setindex KeyIndex, "IndexLASTNAME"
nameofindex$ = "IndexLASTNAME"
CASE 2
key$= string$(len(RecField.FIRSTNAME)," ")
setindex KeyIndex, "IndexFIRSTNAME"
nameofindex$ = "IndexFIRSTNAME"
END SELECT
BrowseIrec nameofindex$, keyindex, Exitcode
IF Exitcode = 0 THEN 'Index is Empty
msg.nodata
EXIT DO
END IF
RETRIEVE keyindex, RecField
'display the details
CALL SAMPLE.scn1'0
CALL SAMPLE.info1
DispLine$(1) = "YES, go ahead and delete displayed record : "+KEY$
DispLine$(2) = "NO, I don't want to delete displayed record : "+KEY$
Imopt = 1
Ques$ = "(Y/N)"
answ$ = "YyNn"
AskQuestion DispLine$(), 2, 1, 2, BLACK, WHITE, BLACK, WHITE, Ques$, answ$
IF UCASE$(answ$) = "Y" THEN
GOSUB InitRecField 'Initialize NAME
DELETE keyindex
END IF
EXIT DO
LOOP
CASE 5 '!!! DELETE ALL DATA AND KEY FILES !!!
DrawBox 21, 22, 40, 3, 2, BLACK, WHITE, 1, BLACK, WHITE, 1
CenterText "Select File to Delete ", 22, BLACK, WHITE
MsgLine "Press for last for next ENTER to select", 25, 0, 7
MFILE$ = SelFiles$("*.DBF")
trim MFILE$
masterfile$ = MFILE$
IF MFILE$ <> "" THEN
DispLine$(1) = "Delete "+ MFILE$ +", Are You Sure ?"
DispLine$(2) = "Yes to erase"+ MFILE$
Ques$ = "(Y/N)"
ans$ = "YyNn"
AskQuestion DispLine$(), 2, 1, 1, BLACK, WHITE, BLACK, WHITE, Ques$, ans$
IF UCASE$(ans$) = "Y" THEN
CLOSE
delimit = INSTR(masterfile$, ".")
IF delimit THEN
dfile$ = LEFT$(masterfile$, delimit - 1)
ELSE
dfile$ = masterfile$
END IF
KILL dfile$ + ".DBF"
GOTO NEWFILE
END IF
END IF
CASE 6 ' display equipment
DspEquipment
CASE 7 'QUIT exit to dos
CLOSE
EXIT DO
CASE 99
CASE ELSE
END SELECT
LOOP
LOCATE 23, 1
COLOR white, black
CLS
END 'End of program
getfieldinfo: ' prints screens and gets record info
op = 1
DO ' loop until page down or esc key
pnc "ESC to exit PgDn TO update, for prev for next F1 edit help", 25, 10, 0, 7
SELECT CASE OP
CASE 1 '
CALL SAMPLE.scn1
CALL SAMPLE.info1
LOCATE 11,22
format$ = "@@@@@@@@@@@@@@"
edit$ = RecField.LASTNAME
Trim edit$
edit$ = FES(0, WHITE, BLACK, edit$, format$, 0, Ek, 1, 0, 1, 1, 1, 0, 1, 0)
RecField.LASTNAME= edit$
SELECT CASE Ek ' get exit key
CASE 1
op = op - 1 ' goto previous field
CASE 5
op = op + 1 ' goto next field
CASE 3
op = op + 1
CASE 4
op = 6 'page down so update
CASE 7
op = 999 'ESC key so exit
END SELECT
CASE 2 '
LOCATE 12,22
format$ = "@@@@@@@@@@@@@@"
edit$ = RecField.FIRSTNAME
Trim edit$
edit$ = FES(0, WHITE, BLACK, edit$, format$, 0, Ek, 1, 0, 1, 1, 1, 0, 1, 0)
RecField.FIRSTNAME= edit$
SELECT CASE Ek ' get exit key
CASE 1
op = op - 1 ' goto previous field
CASE 5
op = op + 1 ' goto next field
CASE 3
op = op + 1
CASE 4
op = 6 'page down so update
CASE 7
op = 999 'ESC key so exit
END SELECT
CASE 3 '
LOCATE 13,22
format$ = "##################################"
edit$ = RecField.ADDRESS
Trim edit$
edit$ = FES(0, WHITE, BLACK, edit$, format$, 1, Ek, 1, 0, 1, 1, 1, 0, 1, 0)
RecField.ADDRESS= edit$
SELECT CASE Ek ' get exit key
CASE 1
op = op - 1 ' goto previous field
CASE 5
op = op + 1 ' goto next field
CASE 3
op = op + 1
CASE 4
op = 6 'page down so update
CASE 7
op = 999 'ESC key so exit
END SELECT
CASE 4 '
LOCATE 14,22
format$ = "999-9999"
edit$ = RecField.PHONE1
Trim edit$
edit$ = FES(0, WHITE, BLACK, edit$, format$, 0, Ek, 1, 0, 1, 1, 1, 0, 1, 0)
RecField.PHONE1= edit$
SELECT CASE Ek ' get exit key
CASE 1
op = op - 1 ' goto previous field
CASE 5
op = op + 1 ' goto next field
CASE 3
op = op + 1
CASE 4
op = 6 'page down so update
CASE 7
op = 999 'ESC key so exit
END SELECT
CASE 5 '
LOCATE 15,22
format$ = "(999) 999-9999"
edit$ = RecField.PHONE2
Trim edit$
edit$ = FES(0, WHITE, BLACK, edit$, format$, 0, Ek, 1, 0, 1, 1, 1, 0, 1, 0)
RecField.PHONE2= edit$
SELECT CASE Ek ' get exit key
CASE 1
op = op - 1 ' goto previous field
CASE 5
op = op + 1 ' goto next field
CASE 3
op = op + 1
CASE 4
op = 6 'page down so update
CASE 7
op = 999 'ESC key so exit
END SELECT
CASE 6 'END REACHED
SELECT CASE mopt 'do option
'INSERT or Change record key
CASE 1 'INSERT
INSERT keyindex, RecField
CHECKPOINT
EXIT DO 'INSERTED!
CASE 2 'Edit, Update
UPDATE keyindex, RecField
CHECKPOINT ' update isam record
EXIT DO
CASE ELSE
END SELECT
CASE 999
EXIT DO
CASE ELSE
END
END SELECT
LOOP
RETURN
InitRecField:
RecField.LASTNAME = ""
RecField.FIRSTNAME = ""
RecField.ADDRESS = ""
RecField.PHONE1 = ""
RecField.PHONE2 = ""
RETURN
DEFINT A-Z
sub SAMPLE.scn1 static
'Display details on screen
fg = white
bg = blue
pnc "LASTNAME : ██████████████",11,4,fg,bg
pnc "FIRSTNAME : ██████████████",12,4,fg,bg
pnc "ADDRESS : ██████████████████████████████████",13,4,fg,bg
pnc "PHONE1 : ████████",14,4,fg,bg
pnc "PHONE2 : ██████████████",15,4,fg,bg
end sub ' SAMPLE
DEFINT A-Z
sub SAMPLE.info1 static
'Display details on screen
fg = white
bg = blue
fg = black
bg = white
PNC userSformat ((RTRIM$(RecField.LASTNAME)),"@@@@@@@@@@@@@@"),11,22, fg, bg
fg = black
bg = white
PNC userSformat ((RTRIM$(RecField.FIRSTNAME)),"@@@@@@@@@@@@@@"),12,22, fg, bg
fg = black
bg = white
PNC userSformat ((RTRIM$(RecField.ADDRESS)),"##################################"),13,22, fg, bg
fg = black
bg = white
PNC userSformat ((RTRIM$(RecField.PHONE1)),"999-9999"),14,22, fg, bg
fg = black
bg = white
PNC userSformat ((RTRIM$(RecField.PHONE2)),"(999) 999-9999"),15,22, fg, bg
end sub ' SAMPLE
DEFINT A-Z
'
SUB mainscreen
bg = white
fg = black
rev = RED
COLOR white, BLUE
DrawBox 1, 1, 80, 25, 2, white, BLUE, 4, white, BLUE, 0
DrawBox 2, 20, 40, 4, 2, black, white, 1, black, white, 1
CenterText " the PROGEN database ", 3, fg, bg
CenterText "By: RAYMOND E DIXON Jacksonville FL", 4, fg, bg
END SUB
DEFINT A-Z
'
' return code = 1 if record exist 0 if no record
'
SUB ISM (cmd$, indexnum, retcode)
trim cmd$
KIMcmd$ = UCASE$(cmd$)
SELECT CASE KIMcmd$
CASE "A" 'add new record
CASE "F" 'move to first record
CASE "P" 'move to previous record
CASE "N"
CASE "L"
CASE "D"
CASE "GE"
CASE "GT"
CASE "EQ"
CASE ELSE
EXIT SUB
END SELECT
SELECT CASE KIMcmd$
'******************************************
CASE "F"'find first
'******************************************
MOVEFIRST indexnum
IF BOF(indexnum) THEN
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "L"'find last key
'******************************************
MOVELAST indexnum
IF EOF(indexnum) THEN
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "EQ"'search for key =
'******************************************
SEEKEQ indexnum, key$
IF EOF(indexnum) THEN
MOVELAST indexnum
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "GE" 'search for key >=
'******************************************
SEEKGE indexnum, key$
IF EOF(indexnum) THEN
MOVELAST indexnum
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "GT" 'search for key >
'******************************************
SEEKGT indexnum, key$
IF EOF(indexnum) THEN
MOVELAST indexnum
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "A" 'add new key
'******************************************
INSERT indexnum, RecField
retcode = 1
'******************************************
CASE "D" 'delete existing key
'******************************************
DELETE indexnum
retcode = 1
'******************************************
CASE "N" ' next key
'******************************************
MOVENEXT indexnum
IF EOF(indexnum) THEN
MOVELAST indexnum
retcode = 0
ELSE
retcode = 1
END IF
'******************************************
CASE "P" ' previous key
'******************************************
MOVEPREVIOUS indexnum
IF BOF(indexnum) THEN
MOVEFIRST indexnum
retcode = 0
ELSE
retcode = 1
END IF
END SELECT
END SUB
DEFINT A-Z
'
' ISMstatus = 1 if records exist, 0 if no records
'
FUNCTION ISMstatus (ixn)
MOVEFIRST ixn
IF BOF(ixn) THEN
ISMstatus = 0
ELSE
ISMstatus = 1
END IF
END FUNCTION
DEFINT A-Z
'
SUB BrowseIrec (nameofindex$, indexnum, Exitcode) STATIC
IF ISMstatus(indexnum) = 0 then
Exitcode = 0
EXIT SUB
END IF
fg = WHITE
bg = BLUE
REDIM dg$(5)
REDIM DispLine$(10)
REDIM TEMPretcode(20)
CONST ex$ = " ESC = Exit ENTER = Select ? = Key search "
'define select option window
ROW = 6
col = 3
lin = 10
numofsel = 0
Exitcode = 0
bodertype = 2 'Border type
Nf = BLACK 'Normal Foreground
Nb = WHITE 'Normal Background
sf = WHITE + 8 'Select Foreground
Sb = BLACK 'Select Background
ff = YELLOW 'Frame Foreground
Fb = BLACK 'Frame Background
'end of select option's
MsgLine ex$, 25, 0, 7
resrt:
KeyLen = 70 ' LEN(key$) for single key display
KeyLen = Maximum(KeyLen, LEN(Ex$))
skey$ = "FIELD NAME"
dg$(1) = "Enter search key"
dg$(2) = "or Part of key "
height = lin
Startpos = height
col = 80 / 2 - KeyLen / 2
dwidth = KeyLen
trim dg$(1)
trim dg$(2)
Dwidth2 = dwidth
dwidth = dwidth + 2
totalheight = height + 2 'Scroll box height plus borders
totalheight = totalheight + 2 'Quit Box + ESC + lineNum
checkheight = totalheight + ROW - 1 'Check the height
IF checkheight > MAXROW THEN
CurMasREC = 0
retcode = 0
EXIT SUB
END IF
CheckWidth = dwidth + col - 1
IF CheckWidth > 80 THEN
CurMasREC = 0
retcode = 0
EXIT SUB
END IF
'Save Screen
GetBackground ROW, col, ROW + totalheight + 2, col + dwidth + 1, buf$
DrawBox ROW, col, dwidth, totalheight, bodertype, ff, Fb, 1, Nf, Nb, 0
Crow = ROW + height + 1
Ccol = col + 1
Acc$ = STRING$(dwidth - 2, 196)
pnc Acc$, Crow, Ccol, ff, Fb
Crow = ROW + height + 2
kcol = Ccol + KeyLen / 2 - LEN(skey$) / 2
pnc skey$, Crow, kcol, ff, Fb
GOSUB homekeys 'Display from the top
GOSUB Displaykeys 'Display the keys
CurrentROW = 1 'Current Row
DO
Acc$ = DispLine$(CurrentROW)
IF LEN(Acc$) < Dwidth2 - 2 THEN
Acc$ = Acc$ + STRING$(Dwidth2 - LEN(Acc$), 32)
END IF
Crow = CurrentROW + ROW
pnc Acc$, Crow, Ccol, sf, Sb
kbd$ = ""
WHILE kbd$ = ""
kbd$ = INKEY$
WEND
IF LEN(kbd$) = 1 THEN
useroption = ASC(RIGHT$(kbd$, 1))
SELECT CASE useroption
CASE 63 '? search key
DialogBox dg$(), 1, 1, 20, ff, Fb, Nf, Nb, 1, ans$,"", Exk
key$ = ans$
'IndexFind
ISM "GE", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(1) = DispLine$
END IF
GOSUB GetNextten
CurrentROW = 1
GOSUB Displaykeys
CASE 48 TO 57, 65 TO 90, 97 TO 122 'first letter search
'IndexFind
key$ = UCASE$(CHR$(useroption))
ISM "GE", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(1) = DispLine$
END IF
GOSUB GetNextten
CurrentROW = 1
GOSUB Displaykeys
CASE 27 'ESCAPE
key$ = ""
retcode = 0
Exitcode = 1 ' ESC
EXIT DO
CASE 13 'RETURN
pnt = INSTR(DispLine$(CurrentROW)," ")
key$ = LEFT$(DispLine$(CurrentROW), pnt)
trim key$
ISM "GE", indexnum, retcode
Exitcode = 2 ' RETURN
EXIT DO
CASE ELSE
END SELECT
END IF
IF LEN(kbd$) = 2 THEN
useroption = ASC(RIGHT$(kbd$, 1))
SELECT CASE useroption
CASE 71 'Home
CurrentROW = 1
GOSUB homekeys
GOSUB Displaykeys
CASE 81 'pg Down
CurrentROW = 1
FOR lineNum = 1 TO height
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
ISM "N", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(1) = DispLine$
END IF
GOSUB GetNextten
GOSUB Displaykeys
CASE 73 'pg Up
CurrentROW = 1
GOSUB GetLastpage
GOSUB Displaykeys
CASE 79 'End
IF Startpos >= height THEN
CurrentROW = 1
GOSUB endkeys
GOSUB Displaykeys
END IF
CASE 80 'Down Arrow
CurrentROW = CurrentROW + 1
IF CurrentROW > height THEN
CurrentROW = CurrentROW - 1
IF TEMPretcode(height) <> 0 THEN
key$ = DispLine$(height)
pnt = INSTR(DispLine$(CurrentROW)," ")
key$ = LEFT$(DispLine$(CurrentROW), pnt)
trim key$
ISM "GE", indexnum, retcode
'IndexNext
ISM "N", indexnum, retcode
IF retcode <> 0 THEN
FOR lineNum = 1 TO height - 1
TEMPretcode(lineNum) = TEMPretcode(lineNum + 1)
DispLine$(lineNum) = DispLine$(lineNum + 1)
NEXT lineNum
GOSUB getreinfo
DispLine$(height) = DispLine$
TEMPretcode(height) = retcode
END IF
END IF
ELSE
IF TEMPretcode(CurrentROW) = 0 THEN
CurrentROW = CurrentROW - 1
END IF
END IF
GOSUB Displaykeys
CASE 72 'Up Arrow
CurrentROW = CurrentROW - 1
IF CurrentROW < 1 THEN
CurrentROW = CurrentROW + 1
key$ = DispLine$(1)
pnt = INSTR(DispLine$(1)," ")
key$ = LEFT$(DispLine$(1), pnt)
trim key$
ISM "GE", indexnum, retcode
retcode = TEMPretcode(1)
Prevretcode = retcode
'IndexPrevious
ISM "P", indexnum, retcode
IF retcode <> 0 THEN
FOR lineNum = height TO 2 STEP -1
TEMPretcode(lineNum) = TEMPretcode(lineNum - 1)
DispLine$(lineNum) = DispLine$(lineNum - 1)
NEXT lineNum
GOSUB getreinfo
DispLine$(1) = DispLine$
TEMPretcode(1) = retcode
END IF
ELSE
IF TEMPretcode(CurrentROW) = 0 THEN
CurrentROW = CurrentROW + 1
END IF
END IF
GOSUB Displaykeys
CASE ELSE
END SELECT
END IF
LOOP
'Restore Screen
PutBackground ROW, col, buf$
buf$ = ""
EXIT SUB
Displaykeys:
FOR lineNum = 1 TO height
Acc$ = DispLine$(lineNum)
IF LEN(Acc$) < Dwidth2 THEN
Acc$ = Acc$ + STRING$(Dwidth2 - LEN(Acc$), 32)
END IF
Crow = ROW + lineNum
pnc Acc$, Crow, Ccol, Nf, Nb
NEXT lineNum
Startpos = lineNum
RETURN
homekeys:
FOR lineNum = 1 TO height
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
ISM "F", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(1) = DispLine$
TEMPretcode(1) = retcode
END IF
Prevretcode = retcode
CurrentROW = 1
GetNextten:
FOR lineNum = 2 TO height
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
FOR lineNum = 2 TO height
DispLine$(lineNum) = STRING$(KeyLen, 32)
TEMPretcode(lineNum) = 0
ISM "N", indexnum, retcode
IF retcode > 0 THEN
IF EOF(indexnum) THEN
EXIT FOR
ELSE
GOSUB getreinfo
DispLine$(lineNum) = DispLine$
TEMPretcode(lineNum) = retcode
Prevretcode = retcode
END IF
ELSE
EXIT FOR
END IF
NEXT lineNum
RETURN
endkeys:
dsppos = 1
FOR lineNum = 1 TO height
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
ISM "L", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(height) = DispLine$
TEMPretcode(height) = retcode
END IF
Prevretcode = retcode
CurrentROW = 1
GetPreviousten:
FOR lineNum = 1 TO height - 1
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
Startpos = 1
FOR lineNum = height - 1 TO 1 STEP -1
DispLine$(lineNum) = STRING$(KeyLen, 32)
ISM "P", indexnum, retcode
IF retcode > 0 THEN
IF EOF(indexnum) THEN
EXIT FOR
ELSE
Startpos = Startpos + 1
GOSUB getreinfo
DispLine$(lineNum) = DispLine$
TEMPretcode(lineNum) = retcode
Prevretcode = retcode
startrpos = Startpos + 1
END IF
ELSE
EXIT FOR
END IF
NEXT lineNum
RETURN
Getnextpage:
key$ = DispLine$(height)
FOR lineNum = 1 TO 2
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
ISM "N", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(1) = DispLine$
TEMPretcode(1) = retcode
ELSE
GOTO endkeys
RETURN
END IF
Prevretcode = retcode
CurrentROW = 1
GetNextpg:
FOR lineNum = 2 TO height
TEMPretcode(lineNum) = 0
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
FOR lineNum = 2 TO height
DispLine$(lineNum) = STRING$(KeyLen, 32)
TEMPretcode(lineNum) = 0
'get Next record
ISM "N", indexnum, retcode
IF retcode > 0 THEN
IF EOF(indexnum) THEN
GOTO endkeys
ELSE
GOSUB getreinfo
DispLine$(lineNum) = DispLine$
END IF
ELSE
GOTO endkeys
END IF
NEXT lineNum
RETURN
GetLastpage:
key$ = DispLine$(1)
FOR lineNum = 1 TO height
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
ISM "P", indexnum, retcode
IF retcode THEN
GOSUB getreinfo
DispLine$(height) = DispLine$
ELSE
GOTO homekeys
END IF
Prevretcode = retcode
CurrentROW = 1
GetLastpg:
FOR lineNum = 1 TO height - 1
DispLine$(lineNum) = STRING$(KeyLen, 32)
NEXT lineNum
FOR lineNum = height - 1 TO 1 STEP -1
DispLine$(lineNum) = STRING$(KeyLen, 32)
ISM "P", indexnum, retcode
IF retcode > 0 THEN
IF EOF(indexnum) THEN
GOTO homekeys
ELSE
GOSUB getreinfo
DispLine$(lineNum) = DispLine$
END IF
END IF
NEXT lineNum
RETURN
getreinfo: 'add if more than key RecField is displayed
RETRIEVE indexnum, RecField
dl$ = userSformat((RTRIM$(RecField.LASTNAME)),"@@@@@@@@@@@@@@") + " "
dl$ = dl$ + userSformat((RTRIM$(RecField.FIRSTNAME)),"@@@@@@@@@@@@@@") + " "
dl$ = dl$ + userSformat((RTRIM$(RecField.ADDRESS)),"##################################") + " "
dl$ = dl$ + userSformat((RTRIM$(RecField.PHONE1)),"999-9999") + " "
dl$ = dl$ + userSformat((RTRIM$(RecField.PHONE2)),"(999) 999-9999") + " "
DispLine$ = LEFT$(Dl$,70)
RETURN
END SUB