home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
FOXPRO
/
PRE307
/
LIBRARY.PRE
< prev
next >
Wrap
Text File
|
1990-03-27
|
35KB
|
1,471 lines
Note Defines and includes
*
#include keydefs.inc
#include stddefs.inc
#define dummy ''
#define maxlen(x,y) max(len(alltrim(x)),len(alltrim(y)))
note Append/Seek Blank
*appenblank
function appenblank
private keyfield,x,tempflt
tempflt = dbfilter()
set filter to
set deleted off
keyfield = indexkey(0)
if .not. empty(keyfield) && if there is a key:
seek blank(&keyfield)
if found()
recall
blankit()
else
append blank
endif
else
locate for deleted()
if found()
recall
blankit()
else
append blank
endif
endif
set deleted on
set filter to &tempflt
return(0)
note Blank Record
*blankit
function blankit
private i
for i = 1 to fcount()
x = field(i)
replace &x with blank(&x)
next
return 0
note Box Center
*boxcenter
function boxcenter
* Syntax: boxcenter([<expN1>],[<expN2>],[<expN3>],[<expN4>],[<expN5>],[<expN6>],[<expN7>])
* Centers a box of width <expN1> and height <expN2> starting at
* row <expN3>, column <expN4>.
parameters width,height,row,col,row2,col2,boxtype
private winwidth,winheight,fcol,tcol
if type([height]) <> 'N'
height = 24
endif
if type([row]) <> 'N'
row = int((24 - height)/2)
endif
if type([width]) <> 'N'
width = 80
endif
if type([boxtype]) <> 'N'
boxtype = 2
endif
if type([col]) <> 'N'
col = 0
endif
winwidth = 80
winheight = 24
if width >= winwidth && Too long to center
fcol = col
else
fcol = col+int((winwidth - width)/2)
endif
tcol = fcol + width - 1
if boxtype = 2 .or. boxtype = 4
@ row,fcol to row+height-1,tcol double
else
@ row,fcol to row+height-1,tcol
endif
if boxtype = 3 .or. boxtype = 4
shadow(row,fcol,row+height-1,tcol)
endif
return fcol && boxcenter
note Box Menu
*boxmenu
*
* Add parameters for message,message location, box around it (y/n).
* Add parameters for type of box (or no box)
*
function boxmenu
parameters array,row,col,height,width,boxtitle,quick,initch,truth,scrnrest
private row2,col2,i,choice,scrn,titcol,initwin
public boxquick
if type([height]) <> 'N'
height = min(len(array)+2,23)
endif
if type([row]) <> 'N'
row = int((24 - height)/2)
endif
row2 = min(row + height - 1,24)
if type([quick]) <> 'L'
boxquick = .t.
else
boxquick = quick
endif
if boxquick
boxstring = ''
for i = 1 to len(array)
boxstring = boxstring + upper(substr(array[i],1,1))
next
endif
if type([boxtitle]) <> 'C'
boxtitle = ''
else
boxtitle = space(2) + alltrim(boxtitle) + space(2)
endif
if type([width]) <> 'N'
width = length(array) + 4
endif
if .not. empty(boxtitle) .and. width < len(boxtitle)+4
width = min(len(boxtitle)+4,80)
if width < len(boxtitle)+4
boxtitle = space(2) + substr(alltrim(boxtitle),1,width - 4) + space(2)
endif
endif
if type([col]) <> 'N'
col = int((79 - width)/2)
endif
col2 = min(col + width - 1,79)
if type([truth]) <> 'L' .and. type([truth]) <> 'A'
truth = .t.
endif
if type([scrnrest]) <> 'L'
scrnrest = .t.
endif
if type([initch]) <> 'N'
initch = 1
endif
* if type([initwin]) <> 'N'
initwin = 0
* endif
if row2 - row < 2 .or. col2 - col < 2 .or. row < 0 .or. row > 24 ;
.or. row2 < 0 .or. row2 > 24 .or. col < 0 .or. col > 79 ;
.or. col2 < 0 .or. col2 > 79
return 0
endif
if scrnrest
scrn = savescreen(row,col,row2+2,col2+2)
endif
@ row,col clear to row2,col2
@ row,col to row2,col2 double
shadow(row,col,row2,col2)
if .not. empty(boxtitle)
center(boxtitle,row,col,col2)
* @ row,titcol-1 , row + 2,titcol + len(boxtitle)+2 box "┌─┐╞┘─└╡"
endif
choice = achoice(row+1,col+2,row2-1,col2-2,array,truth,'boxchoice',initch,initwin)
release boxquick
if scrnrest
restscreen(row,col,row2+2,col2+2,scrn)
endif
return choice
function boxchoice
parameters mode,choice,position
private retcode
if mode = 0
retcode = 2
elseif mode = 1
keypress(ctrl_pgdn)
retcode = 2
elseif mode = 2
keypress(ctrl_pgup)
retcode = 2
elseif mode = 3
if lastkey() = left
keypress(up)
retcode = 2
elseif lastkey() = right
keypress(dn)
retcode = 2
elseif lastkey() = esc
retcode = 0
elseif lastkey() = home
keypress(ctrl_pgup)
retcode = 2
elseif lastkey() = endkey
keypress(ctrl_pgdn)
retcode = 2
elseif lastkey() = enter
retcode = 1
elseif boxquick
if upper(chr(lastkey()))$boxstring
keyboard chr(enter)
endif
retcode = 3
else
retcode = 3
endif
else
retcode = 2
endif
if type('helpchoice') = 'N'
helpchoice = position
endif
return retcode
***************** end boxmenu
note Box Message
*boxmsg
function boxmsg
* add a parameter to stack boxes (i.e. leave top or bottom open) ????
* add a parameter for box type
parameters message,row,col,boxtime,boxcolor
private scrn,tempcolor,row2,col2,height,i,msg,curs
curs = cursor()
set cursor off
if type([message]) = 'A'
height = min(len(message)+2,23)
* width = 0
* for i = 1 to len(message)
* width = max(width,len(message[i]))
* next
* width = min(width + 4,80)
elseif type([boxtime]) = 'N'
if boxtime = 0
if type([message]) <> 'C'
message = 'Press Any key to continue'
else
msg = message
private message[2]
message[1] = msg
message[2] = 'Press Any key to continue'
* width = maxlen(message[1],message[2]) + 4
height = 4
endif
endif
endif
width = min(length(message)+4,80)
if type([message]) = 'C'
* width = min(len(message)+4,80)
height = 5
endif
if type([row]) <> 'N'
row = int((24 - height)/2)
else
if row +height > 22 .or. row < 0
row = int((24 - height)/2)
endif
endif
if type([col]) <> 'N'
col = int((79 - width)/2)
else
if col+width > 79 .or. col < 0
col = int((79 - width)/2)
endif
endif
row2 = min(row + height - 1 ,24)
col2 = min(col + width - 1,79)
tempcolor = setcolor()
if type([boxcolor]) <> 'C'
boxcolor = setcolor()
endif
if type([boxtime]) = 'N' && If a time was passed,
scrn = boxsave(row,col,row2,col2,boxcolor) && save portion of screen
else && else
save screen to scrn && save whole screen
boxsave(row,col,row2,col2,boxcolor)
endif
if type([message]) = 'A'
for i = 1 to height -2
@ row+i,col+2 say message[i]
next
else
@ row+2,col+2 say message
endif
if type([boxtime]) = 'N'
inkey(boxtime)
endif
if type([boxcolor]) = 'C'
setcolor(tempcolor)
endif
if type([boxtime]) = 'N'
* setcolor(tempcolor)
restscreen(row,col,row2+2,col2+2,scrn)
endif
set cursor (curs)
return scrn
******************* end boxmsg
note Build Database
*build
function build
parameters dbffile,dict
private xsel
if .not. file_name(@dbffile,'DBF')
return .f.
endif
if file(dbffile) && if already exists,return.
return .t. && (change this to test structure)
endif && * * * * * * * * *
if type([dict]) = 'C' && dbf name passed.
dbdict = dict
fcount = lastrec() && Number of fields in dbf.
elseif type([dict]) = 'A' && Array passed.
fcount = len(dict) && Number of fields from array.
else
return .f. && bad parameter.
endif
private field[fcount],ftype[fcount],fwidth[fcount]
xsel = select()
select 0
if type([dict]) <> 'A' && Dict passed as dbf.
create (dbffile) from (dict)
else
create t_e_m_p
use t_e_m_p
for i = 1 to fcount && dict passed as array
append blank
replace field_name with substr(dict[i],1,12)
replace field_type with substr(dict[i],13,1)
replace field_len with val(substr(dict[i],15,17))
next
use
create (dbffile) from t_e_m_p
erase "t_e_m_p.dbf"
endif
use
select (xsel)
return (file(dbffile))
******************* end build
note Center a string at a row, between optional columns
*center
function center
* Syntax: center(<expC>[,<expN1>][,<expN2>][,<expN3>])
* Centers <expC> at row <expN1> between column <expN2> and column <expN3>.
parameters string,row,col,col2
private ccol,width
if type([col]) <> 'N'
col = 0
endif
if type([col2]) <> 'N'
col2 = 79
endif
if type([row]) <> 'N'
row = row()
endif
width = col2 - col + 1
if len(string) >= width && Too long to center
ccol = col
else
ccol =col+int((width - len(string))/2)
endif
@ row,ccol say string
return ccol
note File Date
*filedate
* Syntax..: filedate( <expC> )
* Returns.: Date of file <expC>.
function filedate
parameter fname
*-- make sure a parameter was passed
if pcount() = 1 && If parameter passed,
private fdate[1] && declare date array
if adir( fname, '', '', fdate ) = 1 && fill date array
return fdate[1] && return date.
endif
endif
return ctod(' / / ') && No parameter passed.
********************************* filedate
note File Date & Time
*fdatetime
* Syntax..: fdatetime(<expC>,@<expC>,@expD)
* Returns.: .t./.f. if file found/not found.
function fdatetime
parameters fname,fdate,ftime
private fd[1],ft[1]
if adir(fname, '', '', fd,ft) <> 1
return .f.
endif
if type([fdate]) = 'D'
fdate = fd[1]
endif
if type([ftime]) = 'C'
ftime = ft[1]
endif
return .t.
********************************* fdatetime
note Check for Valid File Name
*file_name
function file_name && test for valid filename
parameters fname,ext
if empty(fname)
return .f.
endif
ext = '.' + upper(ext)
fname = upper(fname)
if at('.',fname) = 0
fname = fname + ext
return .t.
elseif at(ext,fname) = 0
return .f.
endif
return .t.
********************************* file_name
note File Time
*filetime
* Syntax..: filetime( <expC> )
* Returns.: Character time string of file <expC>.
function filetime
parameters fname
if pcount() = 1 && If parameter passed,
private ftime[1] && file time array
if adir( fname, '', '', '', ftime ) = 1 && fill time array
return ftime[1] && return time string.
endif
endif
return space(8) && No parameter passed.
******************************* filetime
note Fill Description array.
*filldesc
function filldesc
parameters field,descrip,dbdict
private hasdict,hold,i,fcount
fcount = len(field)
afill(descrip,'') && Initialize descrip array
hasdict = if(pcount() > 2,(if(.not. empty(dbdict),.t.,.f.)),.f.)
* Add option to ignore fields that are not in dict ???
if hasdict && Get dict. descriptions.
private filtname
filtname = alias() && alias name must be filename
hold = select() && Save the work area.
select 0
use (dbdict) && Open dictionary.
if type('dbfile') = 'C' && If dict. has 'dbfile' field
set filter to dbfile = filtname && get the right fields.
go top
endif
do while .not. eof()
i = ascan(field,upper(trim(field_name))) && Find field name from dict.
if i > 0 && If found,
descrip[i] = descript && Put it in the array.
endif
skip
enddo
use && Close dictionary.
select (hold) && Select original work area.
endif
for i = 1 to fcount
if empty(descrip[i])
descrip[i] = field[i]
endif
next
return .t. && filldesc
note Generic Edit Routine
* gedit
function gedit
* add a picture/valid parameter !!!!!
* change this to use memory variables ????
* change to allow passing row,col info.
#define trow 1
#define brow 22
parameters dict,descrip,eduv,carrywhat,pix,vld
* parameters are optional
* dict is the dictionary (dbf or array) with field descriptions
* if dict is missing or null ('') then field names are displayed
* eduv is the edit mode:
* A - Add
* C - Add with carry
* E - Edit
* D - Delete
* U - Undelete
* V - View
* if eduv is missing then 'E' is assumed.
* Carrywhat (valid only if eduv is 'C') is a field name or array of
* fieldnames to carry from the current record to the new record.
* if carrywhat is missing then all fields are carried.
* Vld is an array of expressions for 'valid' parameter of get.
* gedit assumes appropriate filters are set for delete and undelete.
* To limit Add to new records only, set filter before calling gedit.
* Example: rec = lastrec(). set filter to recno() > rec
private i,n,fcount,fx,lk,nk,yn,gedmsg,gpic,gvld
set cursor off
set exact on
if type([eduv]) = 'C'
eduv = upper(eduv)
else
eduv = 'E'
endif
if type([dict]) = 'C' && dbf name passed.
dbdict = dict
fcount = fcount() && Number of fields in dbf.
elseif type([dict]) = 'A' && Array passed.
fcount = len(dict) && Number of fields from array.
else
dbdict = ''
fcount = fcount() && Number of fields in dbf.
endif
*
nk = ' '
yn = 'N'
* fcount = fcount() && Number of fields in dbf.
if type([descrip]) <> 'A'
private descrip[fcount]
endif
private field[fcount],ftype[fcount],fwidth[fcount]
private bop[10],eop[10] && limit of 10 screens.
if eduv $ 'EVAC'
set function 7 to chr(ctrl_w)+'7'
set function 8 to chr(ctrl_w)+'8'
set function 10 to chr(ctrl_w)
if eduv $ 'AC'
set function 9 to chr(ctrl_w)+'9'
nk = '9'
* eduvmsg = ' F9: ADD '
gedmsg = "│ F9: ADD Another Record │ F7/F8: Prev/Next Screen │ F10: Done │"
* gedmsg = "│" +eduvmsg + "│ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
else
eduvmsg = if(eduv = 'E',' EDIT ',' VIEW ')
gedmsg = "│" +eduvmsg + "│ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
endif
* gedmsg = "│ F1: HELP │ PgUp/PgDn: Prev/Next Record │ F7/F8: Prev/Next Screen │ F10: Done │"
elseif eduv $ 'DU'
if eduv = 'D'
eduvmsg = ' DELETE '
else
eduvmsg = ' UNDELETE '
endif
gedmsg = "│" + eduvmsg + "│ CONFIRM (Y/N): │"
else
* Invalid parameter
return .f.
endif
if type([dict]) <> 'A' && Dict passed as file or no params
private descrip[fcount]
afields(field,ftype,fwidth) && Put field names in arrays.
filldesc(field,descrip,dbdict)
else
for i = 1 to fcount && dict passed as array
field[i] = substr(dict[i],1,12)
ftype[i] = substr(dict[i],13,1)
fwidth[i] = val(substr(dict[i],15,17))
next
endif
if type([descrip]) <> 'A' && field is array,but no descrip
private descrip[fcount]
for i = 1 to fcount
descrip[i] = field[i]
next
endif
@ trow,0 clear
@ 24,0 say gedmsg
@ trow,0 to 23,79
do while .t.
set cursor on
if eduv $ 'AC' .and. nk = '9'
if .not. type([carrywhat]) $ 'AC'
gadd(eduv)
else
gadd(eduv,carrywhat)
endif
endif
i = 1
n = 1
nk = ' '
bop[1] = 1
@ trow,70 say '┐Page: '
@ trow+1,70 say '└────────┐'
@ trow,77 say str(n,3)
* center (eduvmsg,trow)
@ trow+2,1 clear to 22,78
@ trow+1,1 say recno()
@ trow+2,1 say ''
do while i <= fcount
fx = field[i]
@ row()+1,1 say trim(descrip[i]) + ' '
gpic = ''
if type([pix]) = 'A'
if .not. empty(pix[i])
gpic = '"' + pix[i] + '"'
endif
elseif type([pix]) = 'C'
gpic = '"' + pix + '"'
endif
if empty(gpic) .and. (fwidth[i]+len(trim(descrip[i])) > 77 .or. ftype[i] == 'M')
gpic = '"@s77"'
@ row()+1,1 say ''
endif
if type([vld]) = 'A'
gvld = vld[i]
else
gvld = ''
endif
if .not. empty(gpic)
if empty(gvld)
@ row(),col() get &fx picture &gpic
else
@ row(),col() get &fx picture &gpic valid &gvld
endif
else
if .not. empty(gvld)
@ row(),col() get &fx valid &gvld
else
@ row(),col() get &fx
endif
endif
if row() >= brow
if eduv $ 'DU' && if delete or undelete
exit && bail out after one screen.
endif
read
set cursor off
lk = lastkey()
nk = chr(inkey())
eop[n] = i
if lk = esc
exit
elseif nk = '7'
n = if(n<2,1,n-1)
i = bop[n] - 1
elseif nk = '8'
if i < fcount
n = n + 1
endif
bop[n] = eop[if(n<2,1,n-1)] + 1
eop[n] = i
else
exit
endif
@ 2,1 clear to 22,78
@ 0,77 say str(n,3)
endif
i = i + 1
enddo
if eduv $ 'DU'
clear gets
yn = 'N'
@ 24,53 get yn picture "Y"
endif
read
set cursor off
lk = lastkey()
nk = chr(inkey())
clear typeahead
if eduv $ 'DU'
if lk = esc
exit
endif
if yn = 'Y'
if eduv = 'D'
delete
else
recall
endif
endif
skip
if eof()
exit
endif
elseif eduv $ 'EVAC'
if eduv $ 'AC'
if lk = esc
blankit()
delete
exit
elseif isblank()
delete
endif
endif
do case
case lk = esc
exit
case lk = ctrl_w .and. nk $ '789'
loop
case lk = ctrl_w
exit
case eduv $ 'AC'
loop
case lk = pgdn .or. lk = enter
skip
if eof()
go bottom
endif
case lk = pgup
if .not. bof()
skip -1
endif
endcase
endif
enddo
set cursor off
return .t.
function gadd
parameters eduv,whatcarry
* Called by gedit.
private i
if pcount() < 1
carry = .f.
else
carry = (upper(eduv) = 'C')
endif
if carry
if pcount() = 2 && If whatcarry exists
if type([whatcarry]) <> 'A' && and it's not an array..
private tempvar
tempvar = &whatcarry
appenblank()
replace &whatcarry with tempvar
else && else if it is an array..
for i = 1 to len(&whatcarry)
private &whatcarry[i]
&whatcarry[i] = &whatcarry[i]
next
appenblank()
for i = 1 to len(&whatcarry)
replace m->&whatcarry[i] with &whatcarry[i]
next
endif
else && Carry but no whatcarry,
fcount = fcount() && carry all fields.
* private adfield[fcount],adfwidth[fcount]
* afields(adfield,dummy,adfwidth)
for i = 1 to fcount
x = field[i]
m->&x = &x
next
appenblank()
for i = 1 to fcount
x = field[i]
replace &x with m->&x
next
endif
else
appenblank()
endif
return .t.
********************************************************************
note Horizontal Bar (double)
*hbar2
function hbar2
parameters row,lcol,rcol,p4,p5,p6,p7,p8,p9,p10
private i
if type([lcol]) <> 'N'
lcol = 0
endif
if type([rcol]) <> 'N'
rcol = 79
endif
if type([row]) <> 'N'
row = row()
endif
@ row,lcol+1 to row,rcol-1 double
@ row,lcol say chr(204) && ╠
@ row,rcol say chr(185) && ╣
if pcount() > 3
for i = 4 to pcount()
x = 'p'+alltrim(str(i))
@ row,&x say chr(206) && ╬
next
endif
return .t.
note Horizontal Bar (single)
*hbar
function hbar
parameters row,lcol,rcol,p4,p5,p6,p7,p8,p9,p10
private i
if type([lcol]) <> 'N'
lcol = 0
endif
if type([rcol]) <> 'N'
rcol = 79
endif
if type([row]) <> 'N'
row = row()
endif
@ row,lcol+1 to row,rcol -1
@ row,lcol say chr(195)
@ row,rcol say chr(180)
if pcount() > 3
for i = 4 to pcount()
x = 'p'+alltrim(str(i))
@ row,&x say chr(197)
next
endif
return .t.
note Is Record Blank ?
*isblank
function isblank
private i
for i = 1 to fcount()
x = field(i)
if .not. empty(&x)
return .f.
endif
next
return .t.
note Prompt for key field to search on
*keyprompt
function keyprompt
*
* if keyfield missing, can I figure out the key ????
*
parameters keyfield,keydesc,row,col,action,vld
private retcd,scrn,kcolor,row2,col2,i,width,height,fstring,sstring
private message,fieldlen
message = "(Press Esc to return to menu)"
fieldlen = length(keyfield)
if .not. type('keydesc') $ 'AC'
keydesc = ''
endif
desclen = length(keydesc)
if type([keyfield]) = 'A'
height = min(len(keyfield)+4,21)
else
height = 5
endif
width = min(fieldlen + desclen + 6,78)
width = max(width,len(message)+4)
if type([col]) <> 'N'
col = int((77 - width)/2)
else
if col+width > 77 .or. col < 0
col = int((77 - width)/2)
endif
endif
if type([row]) <> 'N'
row = int((22 - height)/2)
else
if row + height > 20 .or. row < 0
row = int((22 - height)/2)
endif
endif
row2 = min(row + height - 1 ,22)
col2 = min(col + width - 1,77)
scrn = savescreen(row,col,row2+2,col2+2)
kcolor = setcolor()
setcolor('n/bg,n/w')
@ row+1,col+1 clear to row2-1,col2-1
@ row,col to row2,col2 double
shadow(row,col,row2,col2)
do while .t.
set cursor on
if type([keyfield]) = 'A'
for i = 1 to len(keyfield)
if type('keydesc') = 'A'
@ row+i,col+2 say keydesc[i] get keyfield[i] picture "@K"
else
@ row+i,col+2 say keydesc get keyfield[i] picture "@K"
endif
next
else
if type([vld]) = 'U'
@ row+1,col+2 say keydesc get keyfield picture "@K"
else
@ row+1,col+2 say keydesc get keyfield picture "@K" valid &vld
endif
endif
@ row()+1,col+2 say message
read
set cursor off
if lastkey() = esc
retcd = .f.
exit
endif
if type([action]) = 'L' && get but no seek.
if .not. action
retcd = .t.
exit
endif
endif
if type([keyfield]) = 'A'
fstring = ''
for i = 1 to len(keyfield)
fstring = fstring + string(keyfield[i])
next
fstring = trim(fstring)
else
fstring = trim(string(keyfield))
endif
if empty(fstring)
retcd = .f.
exit
endif
if type([fstring])$'CM'
if type([action]) = 'C'
sstring = action+'("' + fstring + '")'
fstring = &sstring
endif
endif
set softseek on
seek fstring
set softseek off
if .not. eof()
retcd = .t.
exit
else
retcd = .f.
center('Not found.',row2 - 1,col,col2 )
endif
enddo
setcolor(kcolor)
restscreen(row,col,row2+2,col2+2,scrn)
return retcd && keyprompt
note Length of variable
*length
function length
parameters var
private i,j
if type([var]) = 'C'
return len(var)
elseif type([var]) = 'M'
i = var
return len(i)
elseif type([var]) = 'N'
return len(str(var))
elseif type([var]) = 'L'
return 1
elseif type([var]) = 'A'
j = 0
for i = 1 to len(var)
if type('var[i]') <> 'U'
j = max(j,length(var[i]))
endif
next
return j
elseif type([var]) = 'D'
return 8
else
return 0
endif
note Memo Edit
*memed
function memed
parameters infld,r1,c1,r2,c2,xed,memtitle,udf
* If udf is missing, display without pause
private fld,l,c,nk,lk,curs,memoscreen,zoom
#define memedmsg "│ F1: HELP │ Esc: Abort - Changes Lost │ F9: Zoom │ F10: Done │"
#define memomsg "│ F1: HELP │ │ F9: Zoom │ Esc/F10: Done │"
zoom = .f.
push_ckeys() && save function keys
l = 1 && cursor line
c = 0 && cursor column
if type([xed]) <> 'L' && Edit or show only.
xed = .f.
set key F2 to
else
set key F2 to memf2
endif
if type([r1]) <> 'N'
r1 = 4
endif
if type([c1]) <> 'N'
c1 = 2
endif
if type([r2]) <> 'N'
r2 = 22
endif
if type([c2]) <> 'N'
c2 = 78
endif
if type([memtitle]) <> 'C'
memtitle = ''
endif
if type([udf]) <> 'C'
udf = .f.
endif
save screen to memoscreen
set key F9 to memf9
set key F10 to memf10
curs = savecurs() && save cursor position
fld = infld && save orginal data
do while .t.
if xed && If editing,
set key F1 to help_memo && Allow edit help
set key ins to togcurs && and insert cursor toggle,
cursor(if(readinsert(),'half','std'))
else && else
set key F1 to && turn
set key ins to && them
set cursor off
endif && off.
if .not. zoom
center(memtitle,r1-1,c1-1,c2+1)
* center(if(xed,memedmsg,memomsg),24)
if xed
center(memedmsg,24)
fld = memoedit(fld,r1,c1,r2,c2,.t.,"memfunc",64,.f.,l,c)
else
memoedit(fld,r1,c1,r2,c2,.f.,udf)
if type('udf') <> 'C'
exit
endif
endif
else
@ 2,0 clear to 23,79
@ 2,0,23,79 box edit_box
hbar(3)
center(memtitle,3,2,78)
center(if(xed,memedmsg,memomsg),24)
if xed
fld = memoedit(fld,4,3,22,78,.t.,"memfunc",64,.f.,l,c)
else
memoedit(fld,4,3,22,78,.f.,udf)
if type('udf') <> 'C'
exit
endif
endif
endif
lk = lastkey()
if lk = ctrl_w
nk = chr(inkey())
if nk = '|' && F9 was pressed
zoom = (zoom = .f.)
if ! zoom
restore screen from memoscreen
endif
elseif nk = '2' && F2 was pressed
xed = ! xed
else && F10 was pressed
exit
endif
elseif lk = esc && Esc was pressed
fld = infld
restore screen from memoscreen && restore the screen
exit
endif
enddo
pop_keys() && restore function keys
restcurs(curs) && restore cursor
release h_m_first
return fld
function memfunc
parameters status,line,col
l = line
c = col
return 0
procedure memf2
keyboard chr(ctrl_w)+'2'
return
procedure memf9
keyboard chr(ctrl_w)+'|'
return
procedure memf10
keyboard chr(ctrl_w)
return
procedure togcurs
readinsert(.not.readinsert())
cursor(if(readinsert(),'half','std'))
return
#include memohelp.pre
******************************* memed
note Pad
*pad
function pad
parameters string,length
if len(trim(string)) >= length
return string
else
return left(string + space(length),length)
endif
note Right Say
*rsay
function rsay
parameters string,row,col
private rcol
if type([row]) <> 'N'
row = row()
endif
if type([col]) <> 'N'
col = 79
endif
rcol = col - len(string) + 1
@ row,rcol say string
return rcol
note Save,Clear, and Box
*boxsave
function boxsave
parameters row,col,row2,col2,boxcolor
private scrn
scrn = savescreen(row,col,row2+2,col2+2)
if type([boxcolor]) = 'C'
setcolor(boxcolor)
endif
@ row,col clear to row2,col2
@ row,col to row2,col2 double
shadow(row,col,row2,col2)
return scrn
note Search
*search
function search
parameters code
seek code
return(found())
note String Conversion
*string
function string
parameters var,adl,atrim
private i,j
if type([atrim]) <> 'L'
atrim = .t.
endif
if type([var]) = 'C'
return var
elseif type([var]) = 'M'
i = var
return i
elseif type([var]) = 'N'
return str(var)
elseif type([var]) = 'L'
return if(.t.,'T','F')
elseif type([var]) = 'A'
j = ''
if type([adl]) = 'U'
adl = ''
else
adl = string(adl)
endif
for i = 1 to len(var)
if type('var[i]') <> 'U'
if .not. empty(j) .and. .not. empty(var[i])
j = j + adl
endif
if atrim
j = j + trim(string(var[i]))
else
j = j + string(var[i])
endif
endif
next
return j
elseif type([var]) = 'D'
return dtoc(var)
else
return ''
endif
note Vertical Bar (double)
*vbar2
function vbar2
#ignore
parameters col,trow,brow,p4,p5,p6,p7,p8,p9,p10
private i
if type([col]) <> 'N'
col = col()
endif
if type([trow]) <> 'N'
trow = 0
endif
if type([brow]) <> 'N'
brow = 24
endif
@ trow+1,col to brow-1,col double
@ trow,col say chr(203) && ╦
@ brow,col say chr(202) && ╩
if pcount() > 3
for i = 4 to pcount()
x = 'p'+alltrim(str(i))
@ &x,col say chr(206) && ╬
next
endif
#xignore
return .t.
note Vertical Bar (single)
*vbar
function vbar
#ignore
parameters col,trow,brow,p4,p5,p6,p7,p8,p9,p10
private i
if type([col]) <> 'N'
col = col()
endif
if type([trow]) <> 'N'
trow = 0
endif
if type([brow]) <> 'N'
brow = 24
endif
@ trow+1,col to brow-1,col
@ trow,col say chr(194)
@ brow,col say chr(193)
if pcount() > 3
for i = 4 to pcount()
x = 'p'+alltrim(str(i))
@ &x,col say chr(197)
next
endif
#xignore
return .t.
note Yes/No
*yn
function yn
parameters string,row,col,default
private yesno,row2,col2,scrn
yesno = if(type([default]) <> 'C','N',if(upper(default)$'YN',upper(default),'N'))
if type([string]) <> 'C'
string = "Yes or No "
endif
string = string + " (Y/N) ?"
if type([col]) <> 'N'
col = (77 - len(string))/2
endif
if type([row]) <> 'N'
row = 12
endif
col2 = min(len(string)+col+6,79)
row2 = min(row + 4,24)
scrn = boxsave(row,col,row2,col2)
set cursor on
@ row+2,col+2 say string get yesno picture "Y"
read
set cursor off
restscreen(row,col,row2+2,col2+2,scrn)
return yesno
note Convert array to string with semicolons
*atoc
function atoc
parameters arr
* arr is array to convert
* returns string with semicolons
private i,string
string = ''
for i = 1 to len(arr)
string = string + arr[i]
if i < len(arr)
string = string + ';'
endif
next
i = -1
do while .t.
if substr(string,-1,1) = ';'
string = left(string,len(string) - 1)
else
exit
endif
enddo
return string
note Convert character string with semicolons to array
*ctoa
function ctoa
parameters string,arr
* string is string with semicolons
* arr is array to put strings in
* returns false if number of semicolons is greater than array length
* or if number of semicolons is zero - still converts array if possible.
private i,start,size,semicount
store 0 to size,semicount
start = 1
for i = 1 to len(arr)
size = atnext(';',string,i)
if size > 0
semicount = semicount + 1
else
size = len(string) + 1
endif
arr[i] = substr(string,start,size - start)
start = size + 1
next
return .not. (semicount = 0 .or. semicount >= len(arr))
note Expand public array
*arrexpand
function arrexpand
parameters array,bump
private i,j
if type([bump]) <> 'N'
bump = 1
endif
i = len(array)
private temparr[i]
acopy(array,temparr)
public array[i+bump]
acopy(temparr,array)
for j = i + 1 to i + bump
array[j] = blank(array[1])
next
return (i + bump)
note Display and pause
*showme
function showme
parameter x1,x2,x3,x4,x5,x6,x7,x8,x9
private i,y
for i = 1 to pcount()
y = 'x'+alltrim(str(i))
? '['
?? &y
?? ']'
next
?
inkey(0)
return .t.
note Modified read function
*xread
function xread
set cursor on
read
set cursor off
return lastkey()
#include chkntx.pre
* eof