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

msg(" WELCOME TO USDC COMPUTER INVENTORY ",;
" DATABASE ",;
" --------------------------------- ",;
" ",;
" BB/SC 1992 5.01 Version 1.0 ")


initsup()
query_exp = ""

USE computer
INDEX on location to comp


private flds[6], fdes[6], fpic[6], oth[1]

afields(flds)
afields(fdes)
afill(fpic,"")

* this the actual fields

flds[1] = "location"
flds[2] = "make"
flds[3] = "serialno"
flds[4] = "acqcost"
flds[5] = "datepurch"
flds[6] = "memo"

* this is what we want them to look like on the screen

fdes[1] = "LOCATION:"
fdes[2] = "MAKE:"
fdes[3] = "SERIAL NO:"
fdes[4] = "COST:"
fdes[5] = "PURCHASE DATE:"
fdes[6] = "NOTES:"

* this is what we allow in the fields

fpic[1] = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
fpic[2] = "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
fpic[3] = "xxxxxxxxxxxxxxxxx"
fpic[4] = "99999999999.99"
fpic[5] = "99/99/99"
fpic[6] = ""

* this is the other menu stuff

external reporter

private oth[1]
oth[1] = "Do reports;arept()"

viewport(.t.,flds,fdes,fpic,"","",oth,"")

* function library

function arept
use computer
index on location to rept
reporter()
use
use computer
return ""

*----------------------
* Function............VIEWPORT()
* Action..............Multi-optional data entry engine
* Returns.............nothing
* Category............Superfunction
* Syntax..............VIEWPORT([expL],[array1...array7],[expL])
* Description.........Presents a generic data entry screen with multiple
* movement, search, view and editing capabilities.
*
* Options.............[expL] Logical - this is .T. if you want to give
* the user Add,Edit,Delete, and .F. if not. Defaults
* to .T.
*
* Arrays 1-5 and array 7 must have the same # of
* elements. (default is # of fields in DBF). You may
* pass a .f. or a "" to bypass and activate the
* default.
*
*
* [array1] An array of field names. Defaults to
* all fields in DBF.
*
* [array2] An array of field descriptions. Defaults
* to field names. You must pass array1 if you wish
* to pass array2.
*
* [array3] is an array of PICTURES as Character
* expressions to correspond with the FIELDS
* array. Default is pictures as derived by ED_G_PIC()
* If you pass this array, each element must contain
* at least a "".
*
* [array4] is an array of VALID clauses and messages
* to correspond with the FIELDS array. Each
* is in the form "{valid clause};{valid message}"
* The FIELD is represented as a token "@@" in the
* valid clause which is replaced with the current
* edited value at edit time.
* i.e.
* "!empty(@@);Must not be empty"
* If you pass this array, each element must contain
* at least a "".
*
* [array5] is an array of Lookup definitions corresponding
* to the FIELDS array. These are delimited strings
* with 1-4 component parts matching the first
* four parameters of SMALLS(). Delimiter is a
* semicolon (;). As an example, to make a
* lookup definition corresponding to the COMPANY
* field in the FIELDS array, which will lookup
* on the field CORPNAME in the database INSTIT,
* titling the box "Company" and KEYBOARDing
* the contents of CORPNAME if CR pressed :
* "CORPNAME;Company;%INSTIT;CORPNAME".
* If you realize that these 4 components are
* parsed and sent as parameters to SMALLS(), you
* will get the idea.
* If you pass this array, each element must contain
* at least a "".
*
* [array6] [1-9] Character - each of elements 1-9
* is a delimited string in the format
* "{option};{action}" where option is
* a displayed menu option and action is
* a proc to be executed. i.e.:
* "Form Letters;FORMLETR()"
* "List Myfile;FILEREAD(2,2,22,78,'FMYFILE.TXT')"
* Pass 1-9 option/proc combinations. These will
* be presented as an 'Other' menu.
* THESE PROCS MUST BE DECLARED EXTERNAL!!!
*
* [array7] Logical - matches the FIELDS array and
* defines which fields may be edited (.t.) and
* which are display only (.f.)
* If you pass this array, each element must be of
* TYPE Logical.
*
* [expL] Logical - pop up 'Carry Forward' message
* when adding? True/False. Default is True.
*
* Examples............use register
* private flds[fcount()]
* private fdes[fcount()]
* private fval[fcount()]
* private floo[fcount()]
* private fedit[fcount()]
*
* afields(flds)
* afields(fdes)
* afill(fval,"")
* afill(floo,"")
* afill(fedit,.t.)
*
*
* - valids for fields 5 and 6
* fval[5]="!empty(@@);Cannot be empty"
* fval[6]="!empty(@@);Cannot be empty"
* * *- lookups for fields 5 and 6
* floo[5] = "First;First Name;%user%;trim(first)"
* floo[6] = "Last;Last Name;%user;trim(Last)"
*
* *- 'other' menu array
* private oth[3]
* oth[1] = "Read PRG;FILEREAD(1,1,23,79,'s_viewp.prg')"
* oth[2] = "Do Form Letters ;FORMLETR()"
* oth[3] = "Frequency Analysis;FREQANAL()"
*
* * be sure the 'other' procs are pulled in
* EXTERNAL FILEREAD,FREQANAL,FORMLETR
*
* VIEWPORT(.t.,flds,fdes,.f.,fval,floo,oth)
*----------------------
FUNCTION viewport
PARAM allowed,de_flds,de_desc,de_pics,de_vals,de_looks,de_others,de_edit,de_carry
EXTERNAL ctrlw


PRIVATE start_fld,db_size,nbr_rows,max_rows,prior_rec,stand,enh,unsel,last_fld
PRIVATE choice,subchoice,I,nbrmemos,_ik__,_lk__,I,tempbox,tempvar
PRIVATE trow,BROW,preview,oldcolor,tget,allowed,do_other,others
PRIVATE showbox,allowfill,Readex,getlength,atget,sgetlength
PRIVATE oldcursor,oldm1,oldm9
*----------------------

* Adjust m->getlength to appropriate length
* for gets display. Length of description may be adjusted
* accordingly. Default is 45 for getlength.
getlength = 45

sgetlength = "@S"+alltrim(trans(m->getlength,"999"))
atget = 78-m->getlength



*****
SAVE SCREEN TO preview
Readex = Readexit(.T.)
oldcursor = iif(set(16)=0,.f.,.t.)
oldm1 = setkey(-1)
oldm9 = setkey(-9)
initsup()
*- starting field
start_fld = 1
trow = 2
BROW = 22
allowfill = .F.

IF (!TYPE("m->allowed")=="L")
allowed = .T.
ENDIF

IF (!TYPE("m->de_flds")=="A")
private de_flds[fcount()]
private de_desc[fcount()]
afields(m->de_flds)
acopy(m->de_flds,m->de_desc)
db_size = fcount()
else
db_size = aleng(m->de_flds)
ENDIF
PRIVATE de_types[m->db_size],de_lens[m->db_size],de_decs[m->db_size]
fillarr(m->de_flds,m->de_types,m->de_lens,m->de_decs)


IF !(TYPE("m->de_pics")=="A")
PRIVATE de_pics[m->db_size]
Afill(m->de_pics,"")
for m->i = 1 to m->db_size
DO CASE
CASE de_types[m->i] == "C"
*- make sure it fits on the screen
if de_lens[m->i] > m->getlength
de_pics[m->i] = m->sgetlength
endif
CASE de_types[m->i] == "N"
*- convert to a string
if de_decs[m->i]>0
de_pics[m->i] = REPLICATE("9",de_lens[m->i]-(de_decs[m->i]+1))+"."
de_pics[m->i] = de_pics[m->i]+REPLICATE("9",de_decs[m->i])
else
de_pics[m->i] = REPLICATE("9",de_lens[m->i])
endif
CASE de_types[m->i] == "L"
de_pics[m->i] = "Y"
ENDCASE
next
ENDIF
IF (TYPE("m->de_vals")=="A")
for m->i = 1 TO m->db_size
de_vals[m->i] = STRTRAN(de_vals[m->i],"@@","m->workinonit")
NEXT
ELSE
PRIVATE de_vals[m->db_size]
Afill(m->de_vals,"")
ENDIF


IF !(TYPE("m->de_looks")=="A")
PRIVATE de_looks[m->db_size]
Afill(m->de_looks,"")
ENDIF


IF (TYPE("m->de_others")=="A")
do_other = .T.
others = aleng(m->de_others)+1
PRIVATE othermenu[others],otherproc[others]
for m->i = 1 TO m->others-1
othermenu[m->i]=takeout(de_others[m->i],';',1)
otherproc[m->i]=takeout(de_others[m->i],';',2)
NEXT
othermenu[m->others]="Quit Other Menu"
otherproc[m->others]=""
ELSE
do_other = .F.
ENDIF

IF !(TYPE("m->de_edit")=="A")
PRIVATE de_edit[m->db_size]
Afill(m->de_edit,.t.)
ENDIF

IF !(TYPE("m->de_carry")=="L")
de_carry = .t.
ENDIF


*- determine # of rows in box
nbr_rows = MIN(m->db_size,m->brow-m->trow)
last_fld = m->start_fld+m->nbr_rows-1
nbrmemos = 0

PRIVATE de_work[m->db_size]
sfv_initw()

nbrmemos = akount(m->de_types,"M")
IF m->nbrmemos > 0
PRIVATE de_memos[m->nbrmemos]
sfv_initm()
ENDIF


*- sets
*- make F10 seem like ctrl-w
SET KEY -9 TO ctrlw

oldcolor = Setcolor(m->c_normcol)
stand = standard()
enh = enhanced()
unsel = unselected()
@ 0,15,24,79 BOX "ÚÄ¿³ÙÄÀ³ "
@0,18 SAY " VúIúEúW PúOúRúT for file: "+TRIM(ALIAS())+' '
IF m->nbr_rows < m->db_size
@24,18 SAY "¶ Pgup Pgdn Ç"
ENDIF
Setcolor(m->c_popcol)
@ 0,0,24,14 BOX "ÉÍ»º¼ÍȺ "
@18,1 SAY "ÄÄÄÄÄÄÄÄÄÄÄÄ"
@0,2 SAY " Menu "
* display the menu screen
*----------------------
*- main loop

*- fill in the first set of field pictures
choice = 1

sfv_says(.T.)
DO WHILE .T.
SET CURSOR OFF
SET COLOR TO (m->c_popmenu)
@2,2 PROMPT "Next Record"
@ROW()+1,2 PROMPT "Prev Record"
@ROW()+1,2 PROMPT "Search File"
@ROW()+1,2 PROMPT "Key Search"
@ROW()+1,2 PROMPT "TableView"
@ROW()+1,2 PROMPT "Hardcopy"
@ROW()+1,2 PROMPT "Viewmemo"
@ROW()+1,2 PROMPT "Build Query"
@ROW()+1,2 PROMPT "Field Order"
IF m->allowed
@ROW()+1,2 PROMPT "Edit Record"
@ROW()+1,2 PROMPT "Add Record"
@ROW()+1,2 PROMPT "Memo Edit"
@ROW()+1,2 PROMPT IIF(DELETED(),"UnDelete","Delete ")
ENDIF (m->allowed
IF m->do_other
@ROW()+1,2 PROMPT "Other Menu"
ENDIF
@ROW()+1,2 PROMPT "Quit"
@19,2 SAY "Rec# "
@20,2 SAY STR(RECNO())
@21,2 SAY "of # "
@22,2 SAY STR(RECC())
@23,2 SAY IIF(DELETED(),"Deleted"," ")
MENU TO choice
SET COLOR TO (m->c_popcol)
DO CASE
CASE ispart(LASTKEY(),3,18,1,6)
sfv_disp(LASTKEY())
CASE choice = 1
SKIP
if eof()
go bott
endif
sfv_initw()
sfv_says(.F.)
CASE choice = 2
SKIP -1
sfv_initw()
sfv_says(.F.)
CASE choice = 3
searchme(m->de_flds,m->de_types,de_lens)
KEYBOARD "@"
INKEY()
sfv_initw()
sfv_says(.F.)
CASE choice = 4
tempvar = INDEXKEY(0)
IF !EMPTY(m->tempvar)
_ik__ = INDEXKEY(0)
IF TYPE(m->_ik__)=="C"
_lk__ = SPACE(MAX(LEN(&_ik__),20))
popread(.T.,"Index key to seek (enter for LOOKUP TABLE) :",@_lk__,"")
IF !EMPTY(m->_lk__)
SET SOFTSEEK ON
SEEK m->_lk__
SET SOFTSEEK OFF
ELSE
smalls(_ik__,"Lookup Table of Key")
ENDIF
ENDIF
sfv_initw()
sfv_says(.F.)
ELSE
msg("No index files open - no KEY present")
ENDIF
CASE choice = 5
showbox = makebox(0,0,24,79,Setcolor(),0)
@2,1 TO 2,78
@1,1 SAY "USE Up Down Right Left PGUP PGDN HOME END keys Press ENTER when done"
Setcolor(m->c_normcol)
EDITDB(.t.,3,1,23,78, m->de_flds,'','',de_desc)
Setcolor(m->c_popcol)
unbox(m->showbox)
sfv_initw()
sfv_says(.F.)
CASE choice = 6
sfv_hard()
CASE choice = 7
IF m->nbrmemos > 0
subchoice = 1
IF m->nbrmemos > 1
subchoice = mchoice(m->de_memos,2,15,3+m->nbrmemos,26,"Which Memo:")
if m->subchoice = 0
loop
endif
ENDIF
showbox = makebox(0,15,24,79,Setcolor(),0)
tget = de_memos[m->subchoice]
tget = HARDCR(&tget)
@0,18 SAY '[VIEWING MEMO FIELD: '+de_memos[m->subchoice]+' Press ESCAPE when done]'
Memoedit(m->tget,1,16,23,78,.F.,'',200)
unbox(m->showbox)
ELSE
msg("No memo fields detected","")
ENDIF
CASE choice = 8
QUERY(m->de_flds,m->de_desc,m->de_types,"To ViewPort")
CASE choice = 9
sfv_forder()
sfv_initw()
IF m->nbrmemos > 0
sfv_initm()
ENDIF
sfv_says(.T.)
CASE choice = 10 .AND. m->allowed .AND. RECC()>0
sfv_editit(1)
UNLOCK
sfv_initw()
sfv_says(.F.)
CASE choice = 11 .AND. m->allowed
sfv_editit(2)
UNLOCK
sfv_initw()
sfv_says(.F.)
CASE choice = 12 .AND. m->allowed && edit memo
IF m->nbrmemos > 0
subchoice = 1
IF m->nbrmemos > 1
subchoice = mchoice(m->de_memos,2,15,3+m->nbrmemos,26,"Which Memo:")
if m->subchoice = 0
loop
endif
ENDIF
editmemo(de_memos[m->subchoice],0,15,24,79,.t.)
ELSE
msg("No memo fields detected","")
ENDIF
CASE choice = 13 .AND. m->allowed
if SREC_LOCK(5,.T.,"Network error locking record. Keep trying?")
IF DELETED()
RECALL
ELSE
DELETE
ENDIF
unlock
goto recno()
endif
sfv_initw()
CASE (m->choice = 10.OR. m->choice=14) .AND. (m->do_other)
*- other
tempbox = makebox(8,6,10+m->others,6+BIGELEM(m->othermenu)+2)
@9,8 PROMPT othermenu[1]
for m->i = 2 TO m->others
@ROW()+1,8 PROMPT othermenu[m->i]
NEXT
I = 1
MENU TO I
unbox(m->tempbox)
IF m->i > 0 .AND. m->i < m->others
tempvar = otherproc[m->i]
I = &tempvar
ENDIF
OTHERWISE
IF MESSYN("Exit Now ?")
SET CURSOR (m->oldcursor)
SETKEY(-1,m->oldm1)
SETKEY(-9,m->oldm9)
Readexit(m->readex)
Setcolor(m->oldcolor)
RESTORE SCREEN FROM m->preview
RETURN ''
endif
ENDCASE
ENDDO


FUNCTION sfv_disp
PARAM lkey
IF !(m->nbr_rows < m->db_size)
RETURN ''
ENDIF
PRIVATE oldstart
oldstart = m->start_fld
Setcolor(m->c_normcol)
DO CASE
CASE m->lkey = 3
IF m->last_fld#m->db_size
start_fld = m->start_fld+1
last_fld = m->last_fld+1
Scroll(m->trow,16,m->brow,78,1)
prnt(m->trow+m->nbr_rows-1,18,de_desc[m->start_fld+m->nbr_rows-1],m->stand)
prnt(m->trow+m->nbr_rows-1,m->atget,sfv_makep(m->start_fld+m->nbr_rows-1),m->unsel)
ELSE
CLEAR TYPEAHEAD
ENDIF (m->last_fld#m->db_size
CASE m->lkey = 18
IF m->start_fld>1
start_fld = m->start_fld-1
last_fld = m->last_fld-1
Scroll(m->trow,16,m->brow,78,-1)
prnt(m->trow,18,de_desc[m->start_fld],m->stand)
prnt(m->trow,m->atget,sfv_makep(m->start_fld),m->unsel)
ELSE
CLEAR TYPEAHEAD
ENDIF (m->start_fld>1
ENDCASE
Setcolor(m->c_popcol)
RETURN ''



FUNCTION sfv_says

PARAM saystoo

PRIVATE kounter,curr_row,oldcol
oldcol = Setcolor(m->c_normcol)

curr_row = m->trow
IF m->saystoo
Scroll(m->trow,16,m->brow,78,0)
FOR m->kounter = m->start_fld TO m->last_fld
*- say the description
@m->curr_row,18 SAY de_desc[m->kounter]
m->curr_row = m->curr_row+1
NEXT
ENDIF
Setcolor(takeout(Setcolor(),',',5))
curr_row = m->trow
FOR m->kounter = m->start_fld TO m->last_fld
*- simulate a get field in unselected color
@m->curr_row,m->atget SAY sfv_makep(m->kounter)
m->curr_row = m->curr_row+1
NEXT
Setcolor(m->oldcol)
RETURN ''

FUNCTION sfv_makep
PARAM nbr
IF de_types[M->NBR]=="M"
RETURN "(MEMO)"
ELSEIF de_types[M->NBR]=="C"
RETURN LEFT(de_work[m->nbr],m->getlength)
ELSE
RETURN TRANS(de_work[m->nbr],de_pics[m->NBR])
ENDIF

FUNCTION sfv_forder
PRIVATE pk,pos,sel,tmp,pk2
PRIVATE tmp[7]
pk = makebox(2,9,21,65)
@ 2,28 SAY "Â"
@ 18,9 SAY 'Ã'
@ 21,28 SAY "Á"
@ 3,28 SAY "³ Field Viewing Order:"
@ 4,28 SAY "³"
@ 5,28 SAY "³ The fields for this datafile may"
@ 6,28 SAY "³ be viewed in any order. "
@ 7,28 SAY "³"
@ 8,28 SAY "³ "
@ 9,28 SAY "³ "
@ 10,28 SAY "³"
@ 11,28 SAY "³ Press ENTER to select a field to"
@ 12,28 SAY "³ move. You will be prompted for the"
@ 13,28 SAY "³ position to move it to."
@ 14,28 SAY "³"
@ 15,28 SAY "³"
@ 16,28 SAY "³"
@ 17,28 SAY "³"
@ 18,10 SAY "ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ´"
@ 19,28 SAY "³ Press ESCAPE when done."
@ 20,10 SAY "Total Fields: ³"
@ 20,23 SAY LTRIM(STR(m->db_size))
pos = 1
sel = 1
DO WHILE .T.
sel = m->pos
sel = ACHOICE(4,12,17,27,m->de_desc)
IF m->sel = 0
EXIT
ENDIF
SET CURSOR ON
@ 19,10 SAY "New position:" GET m->pos PICT "99"
READ
@ 19,10 SAY " "
SET CURSOR OFF
IF m->pos <= 0
pos = 1
ELSEIF m->pos > m->db_size
pos = m->db_size
ENDIF

sfv_ashift(m->de_flds,m->sel,m->pos)
sfv_ashift(m->de_desc,m->sel,m->pos)
sfv_ashift(m->de_types,m->sel,m->pos)
sfv_ashift(m->de_lens,m->sel,m->pos)
sfv_ashift(m->de_pics,m->sel,m->pos)
sfv_ashift(m->de_vals,m->sel,m->pos)
sfv_ashift(m->de_looks,m->sel,m->pos)
sfv_ashift(m->de_edit,m->sel,m->pos)
pos = m->pos+1
ENDDO
unbox(m->pk)
RETURN ''

FUNCTION sfv_ashift
PARAM ar,cur,new
PRIVATE I,END
PRIVATE tmp
tmp = ar[m->cur]
IF m->cur > m->new
I = m->cur
DO WHILE m->i > m->new
ar[m->i] = ar[(m->i-1)]
I = m->i-1
ENDDO
ar[m->new] = m->tmp
ELSEIF m->cur < m->new
END = m->new-1
for m->i = m->cur TO m->end
ar[m->i] = ar[m->i+1]
NEXT
ar[m->new] = m->tmp
ENDIF
RETURN ''




FUNCTION sfv_initw
FOR m->i = 1 TO m->db_size
f_ie_ld_name = de_flds[m->i]
IF de_types[m->i]$"CNDL"
de_work[m->i] = &f_ie_ld_name
ENDIF
NEXT
RETURN ''


FUNCTION sfv_editit
PARAM edit_add
PRIVATE adding,kounter,f_ie_ld_name
PRIVATE on_field,curr_row,LASTKEY,recnbr,tempvar
PRIVATE valclause,valmsg,workinonit,preord


adding = (m->edit_add = 2)
IF m->adding
recnbr = RECNO()
GO BOTT
SKIP 1
IF RECC()>0 .and. m->de_carry
IF !messyn("Carry contents of current record forward?","No","Yes")
GO m->recnbr
ENDIF
ENDIF
sfv_initw()
IF m->recnbr > 0
GO m->recnbr
ENDIF
ELSE && editing, lock record
IF !SREC_LOCK(5,.T.,"Network error locking record. Keep trying?")
return ''
endif
sfv_initw()
sfv_says(.F.)
ENDIF


Setcolor(m->c_normcol)
@24,18 SAY "¶ F10 to save ESC to cancel F2 for LookupÇ"
start_fld = 1
last_fld = m->start_fld+m->nbr_rows-1

sfv_says(.T.)

on_field = 1
curr_row = m->trow

DO WHILE .T.
Setcolor(m->c_normcol)
SET CURSOR ON
SET KEY -1 TO sfv_lookup
workinonit = de_work[m->on_field]
IF de_types[m->on_field]=="M"
prnt(m->curr_row,40,"û",m->enh)
@m->curr_row,43 SAY "MEMO - use Memo Edit"
@m->curr_row,40 say ""
INKEY(0)
@m->curr_row,40 SAY " "
ELSEIF EMPTY(de_vals[m->on_field])
IF de_edit[m->on_field]
@m->curr_row,m->atget GET m->workinonit PICT de_pics[m->on_field]
READ
ELSE
prnt(m->curr_row,m->atget,sfv_makep(m->on_field),m->enh)
INKEY(0)
ENDIF
ELSE
IF de_edit[m->on_field]
valclause = takeout(de_vals[m->on_field],';',1)
valmsg = takeout(de_vals[m->on_field],';',2)
@m->curr_row,m->atget GET m->workinonit PICT de_pics[m->on_field] ;
VALID genval(m->valclause,m->valmsg)
READ
ELSE
prnt(m->curr_row,m->atget,sfv_makep(m->on_field),m->enh)
INKEY(0)
ENDIF
ENDIF
de_work[m->on_field] = m->workinonit
SET KEY -1 TO
prnt(m->curr_row,m->atget,sfv_makep(m->on_field),m->unsel)
DO CASE
CASE ispart(LASTKEY(),18,5)
*- decrease field, minimum 1
IF m->on_field > 1
on_field = m->on_field-1
IF m->curr_row = m->trow
sfv_disp(18)
ELSE
curr_row = m->curr_row-1
ENDIF
ENDIF
CASE ispart(LASTKEY(),27,23)
EXIT
OTHERWISE
IF m->on_fielddb_size
on_field = m->on_field + 1
IF m->curr_row = m->brow-1
sfv_disp(3)
ELSE
curr_row = m->curr_row+1
ENDIF
ELSE
* cursor or ENTER key. Check for if done.
IF MESSYN("Done?")
exit
endif
ENDIF
ENDCASE
ENDDO
Setcolor(m->c_normcol)
@24,18 TO 24,78
IF m->nbr_rows < m->db_size
@24,18 SAY "¶ Pgup Pgdn Ç"
ENDIF
IF !LASTKEY() = 27
IF messyn("Save changes ?")
DO WHILE .T.
IF m->adding
IF !SADD_REC(5,.T.,"Network error adding record. Keep trying?")
EXIT
ENDIF
* record is locked after a successful APPEND BLANK
ENDIF
preord = INDEXORD()
SET ORDER TO 0
for m->i = 1 TO m->db_size
IF de_edit[m->i] .AND. (!de_types[m->i]=="M")
tempvar = de_flds[m->i]
REPLACE &tempvar WITH de_work[m->i]
ENDIF
NEXT
SET ORDER TO (m->preord)
EXIT
ENDDO
ENDIF
ENDIF
unlock
GOTO RECNO() && TO flush
RETURN ''


FUNCTION sfv_lookup
PRIVATE I,temp,lookstrng,sparams
IF !EMPTY(de_looks[m->on_field])
lookstrng = de_looks[m->on_field]
PRIVATE l_array[4]
sparams = 0
for m->i = 1 TO 4
temp = takeout(m->lookstrng,';',m->i)
IF EMPTY(m->temp)
EXIT
ENDIF
l_array[m->i] = m->temp
sparams = m->sparams+1
NEXT
DO CASE
CASE m->sparams = 1
smalls(l_array[1])
CASE m->sparams = 2
smalls(l_array[1] ,l_array[2])
CASE m->sparams = 3
smalls(l_array[1] ,l_array[2],l_array[3])
CASE m->sparams = 4
smalls(l_array[1] ,l_array[2],l_array[3],l_array[4])
ENDCASE
ELSE
msg("No lookup defined for this field..")
ENDIF
RETURN ''

FUNCTION sfv_initm
PRIVATE kounter,I,fc
kounter = 0
fc = m->db_size
FOR m->i = 1 TO m->fc
IF de_types[m->i] = "M"
kounter = m->kounter + 1
de_work[m->i] = "(memo)"
de_memos[m->kounter] = de_flds[M->i]
ENDIF
NEXT

FUNCTION sfv_hard
PRIVATE aspect,pmemo,I,mlines,target,_to_file_
aspect = 1
target = 1

DO WHILE .T.
IF m->nbrmemos > 0
aspect = menu_v("Hardcopy of:","Current record ","Attached Memo field ")
IF m->aspect = 0
EXIT
ENDIF
ENDIF
target = menu_v("Send hardcopy to:","Printer ","Text File")
IF m->target = 0
EXIT
ENDIF
IF m->target = 1
_SUPERPRN= prnport()
IF !p_ready(m->_SUPERPRN)
EXIT
ENDIF
ELSE
_to_file_ = SPACE(12)
popread(.F.,"File to send output to ",@_to_file_,"@N")
IF EMPTY(m->_to_file_)
EXIT
ENDIF
IF FILE(m->_to_file_)
IF !messyn("File "+m->_to_file_+" exists, and will be overwritten. Continue ?")
LOOP
ENDIF
ENDIF
SET PRINTER TO (getdfp()+m->_to_file_)
ENDIF
SET PRINT ON
IF m->aspect = 1
SET CONSOLE OFF
for m->i = 1 TO m->db_size
?addspace(de_flds[m->i],12)
_the_field_ = de_flds[m->I]
IF de_types[M->i]=="M"
??"(memo)"
ELSEIF de_types[M->i]=="C"
??LEFT(&_the_field_,60)
ELSE
??TRANS(&_the_field_,de_pics[m->I])
ENDIF
IF (m->i%60)=0
EJECT
ENDIF ((m->i%60)=0
NEXT
IF (m->i%60)<>0
EJECT
ENDIF ((m->i%60)<>0
ELSE
IF m->nbrmemos > 1
I = mchoice(m->de_memos,8,27,15,54,"Memo field to print")
IF m->i = 0
RETURN ''
ENDIF
pmemo = de_memos[m->i]
ELSE
pmemo = de_memos[1]
ENDIF

pmemo = &pmemo
mlines = MLCOUNT(m->pmemo,79)
SET CONSOLE OFF
IF !EMPTY(m->pmemo)
FOR m->i = 1 TO m->mlines
?MEMOLINE(m->pmemo,79,I)
IF (m->i%60)=0
EJECT
ENDIF ((m->i%60)=0

NEXT
IF (m->i%60)<>0
EJECT
ENDIF ((m->i%60)<>0
ELSE
msg("This memo field is empty")
ENDIF
ENDIF (m->aspect = 1
SET PRINTER TO (m->_SUPERPRN)
SET PRINT OFF
SET CONSOLE ON
EXIT
ENDDO
RETURN ''
*: EOF: S_VIEWP.PRG