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

 
Output of file : DBLOOKUP.PRG contained in archive : DBLOOKUP.ZIP
function db_find
parameters dbf_name, list_exp, ret_field, rr1, cc1, rr2, cc2
private dbf_name, list_exp, ret_field, rr1, cc1, rr2, cc2
private ar_field, s_name, last_rec, tlast_rec, rvalue
*public rvalue
***********************************************************
* *
* db_find(<...>) *
* *
* Written by: Robert Marchetti *
* revdate: 30 April, 1991 *
***********************************************************
SET CURSOR OFF
flash_col = left(vcfindsrc,at("/",vcfindsrc)-1)+"*"+ substr(vcfindsrc,at("/",;
vcfindsrc))
s_name = ""
last_rec = 0
tlast_rec = 0
save screen to dbfind_scn
select &dbf_name
num_recs = reccount()
rr2 = iif(num_recs < rr2-rr1-1, rr1+num_recs+1, rr2)
set color to " / "
@rr1+1,cc1+1,rr2+1,cc2+1 box single_ln
set color to &vcfindbox
@rr1,cc1,rr2,cc2 box single_ln
@rr2,cc2-25 SAY "{_" + space(19) + "}"
set color to &vcfindsrc
@rr2,cc2-24 say space(20)
set color to &flash_col
@rr2,cc2-24 say "_"
set color to &vcfindtx
declare ar_field[1]
ar_field[1] = list_exp
dbedit(rr1+1,cc1+1,rr2-1,cc2-1,ar_field,"dbfind_udf","","","")
set color to &vcnorm
restore screen from dbfind_scn
return(rvalue)


function dbfind_udf
parameters dbstatus, ar_pos
private dbstatus, rval
*****************************
* revdate: April 31, 1991
*****************************
key = lastkey()
DO CASE
CASE dbstatus = 0 && idle
rval = 1
CASE dbstatus = 1 && beginning of file
beep()
rval = 1
CASE dbstatus = 2 && end of file
beep()
rval = 1
CASE dbstatus = 3 && no file
poperror('No data file active or file is empty.')
rval = 0
CASE dbstatus = 4 && keystroke exception
rval = lookupstrk(key)
ENDCASE
RETURN(rval)

FUNCTION lookupstrk
PARAMETER keypress
PRIVATE keypress, rval
*****************************
* revdate: April 31, 1991
*****************************
DO CASE
CASE keypress = 27 .or. key = -9 && Escape or F10 key pressed
rval = 0
rvalue = 0
CASE keypress = 13 && carriage return
rval = 0
rvalue = &ret_field && load proper value
OTHERWISE
rval = find(keypress)
ENDCASE
RETURN(rval)

function find
parameters key
*****************************
* revdate: 30 april, 1991
*****************************
set color to &vcfindsrc
@rr2,cc2-24 say s_name
preadchr("s_name",20,key)
seek s_name
If eof()
beep(1)
rval=1
go last_rec
else
last_rec = recno()
if tlast_rec <> last_rec
rval = 2
else
rval = 1
endif
tlast_rec = last_rec
endif
set color to &vcfindtx
return(rval)


FUNCTION preadchr
PARAMETERS pread_var, max_len, key
PRIVATE max_len
***********************************************************
* revdate: May 2,1991 *
************************************************************
DO CASE
CASE isalpha(chr(key)) .or. (key >= 32 .and. key <= 64)
IF len(&pread_var) >= max_len -1
beep(1)
return(key)
endif
@ row(),col() say chr(key)
set color to &flash_col
@ row(),col() say "_"
&pread_var = &pread_var + chr(key)
CASE key = 8 .and. len(&pread_var) > 0
set color to &flash_col
@ row(),col()-1 SAY '_ '
&pread_var = substr(&pread_var,1,len(&pread_var)-1)
ENDCASE
RETURN(key)



  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : DBLOOKUP.ZIP
Filename : DBLOOKUP.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/