'UINTLIB.PF3 '**** FUNCTION DECLARATIONS ********************************************* 'core ' external _shade() $screen ver count base 'new for SHADE external $screen ver count base 'new for SHADE public fentrybox() 'centered/formatted input box for string or value public colfentbox() 'centered/formatted input box for string or value; choose colour public keybox() 'centered,horizontal hot key box w/ prompt public flashmess() ' public messbox() 'centered "yes/no" message box public messboxNOSH() 'centered "yes/no" message box - No Shading public colmessbox() 'centered "yes/no" message box ; choose colour public messboxwait() 'centered "yes/no" message box - JDC wait for inchar public popuplist() 'centered arrow select type box '1.04 02/26/91 MS / now accumulates select list as 'as selections made, in select order, using a copy 'of delstr() to remove choices deselected public popuplistcnt() 'centered arrow select type box public findpopup() 'JDC amended to locate findstr in popup public findcolpop() 'JDC amended - locate findstr in popup - choose color public colpopup() 'JDC amended - choose color public colpoplines() 'JDC amended - choose color public posnpopup() 'JDC amended - position @ linenr public posncolpopup() 'JDC amended - position @ linenr public reqnpopup() 'JDC amended - no-border colours 15/0 public redfentry() 'centered/formatted input box for string or value public vkeybox() 'vertical hot key box at row/col public mess4() public mess3() public NameAddressAsk() public entrylineCONV() public entryline() public messline() global uistrcnt() 'required by popuplist (from strlib.psl) global udelstr() 'required by popuplist (from strlib.psl) global chkstr() 'required by findpopup (from strlib.psl) '**** VARIABLE DECLARATIONS ********************************************* 'library public fgi bgi scr scc psa dsa fgp bgp fge bge fgs bgs ptstr ptval public currlib 'core ' used by popuplist global refresh() global c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr nr global plist[1,3] drows colSf colSb '**** CODE ************************************************************** '**** N.B. ************************************************************** ' scr has been changed from 1/2 screen ht to a value of 13 - needed in changeover from 25 lines to 35 ' to avoid messbox() obscuring some input boxes below tables '**** N.B. ************************************************************** MAIN local ptpsl ptpsl = "uintlib" ' message "scr) is:"&str(scr) if currlib = 0 currlib = ptpsl lock module currlib else if chr(32)|lower(currlib)|chr(32) !! chr(32)|ptpsl|chr(32) currlib = currlib & ptpsl end if end if if fgi = 0 fgi = fginvpleasing lock module fgi end if if bgi = 0 bgi = bginvpleasing lock module bgi end if if fgp = 0 fgp = fgpleasing lock module fgp end if if bgp = 0 bgp = bgpleasing lock module bgp end if if fge = 0 fge = fgerror lock module fge end if if bge = 0 bge = bgerror lock module bge end if if fgs = 0 fgs = fgstandard lock module fgs end if if bgs = 0 bgs = bgstandard lock module bgs end if if ptstr = 0 ptstr = NULL lock module ptstr end if if ptval = 0 ptval = BLANK lock module ptval end if if scc = 0 scc = int(scrwidth/2) lock module scc end if if scr = 0 ' scr = int(scrheight/2) scr=13 lock module scr end if if dsa = 0 dsa = NULL lock module dsa end if if psa = 0 psa = NULL lock module psa end if END MAIN function popuplistcnt(r1,br,list,msg,num,mnu) local t hml hm cnum mscn pad padc ret maxl lmsg c3 scw c1 c2 scw=scrwidth ' c1 colSf = fgp colSb = bgp if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen maxl=0 for c=1 to recs plist[c,2]=group(list,c) ' x=plist[c,2] 'message "x is:"&str(x) l=len(plist[c,2]) 'message "l is:"&str(l) if l>maxl maxl=l end if plist[c,1]=0 if l>blen blen=l end if end for lmsg=maxl if lmsg + 4 > scrwidth return (-2) end if c3 = int((scw-lmsg)/2)+1 c1=c3-2 'message "c1 is:"&str(c1) c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad fgp bgp pc=1 for c=1 to pl screen print c+r1 lc fgp bgp plist[c,2] end for if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] drows = pl while TRUE k=inchar screen print r1+c lc fgp bgp plist[rec,2] if plist[rec,1]=1 screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} for c=recs to 1 step -1 if plist[c,1]=1 ret=ret & trim(plist[c,2]) end if end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa nr = c clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) ptval = nr return (0) end if end function 'popuplist() FUNCTION NameAddressAsk(msg1,msg2) ' function mess3(msg1,msg2,msg3,msg4) 'D.Cooper local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err q cc endmess q = 1 err = 0 endmess = " Correct? (y/n) " ' endmess = msg4 k=0 fc1=fgp bc1=bgp fc2=fgi bc2=bgi mbox = scrwidth lmsg=max(len(msg1),len(msg2),len(endmess)+2) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if cc = scrwidth/2-(len(endmess)/2)+1 screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr-1 c3 fgp bgp msg1 screen print scr c3 fgp bgp msg2 screen print scr+1 cc fc2 bc2 endmess screen save r1 c1 r2 c2 dsa WHILE "yn" !! k locate scr+1 (cc+len(endmess)-1) 1 k=inchar k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) END FUNCTION' NameAddressAsk() FUNCTION colpopup(r1,c1,br,list,msg,num,mnu,colSf,colSb,colIf,colIb) local t hml hm cnum mscn pad padc ret if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 colIb bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if screen save r1 c1 r2+2 c2+pad psa 'NEW ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad colSf colSb pc=1 for c=1 to pl screen print c+r1 lc colSf colSb plist[c,2] end for if msg > null screen print r2+2 c1 colIf colIb str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc colIf colIb plist[rec,2] drows = pl while TRUE k=inchar screen print r1+c lc colSf colSb plist[rec,2] if plist[rec,1]=1 screen print r1+c sc colSf colSb sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) colSf colSb 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) colSf colSb 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) ' refresh(c,r1,c1,r2,c2,pad) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc colIf colIb plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc colIf colIb plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc colIf colIb sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) return (0) end if end function 'colpopup() FUNCTION colpoplines(r1,c1,br,list,msg,num,mnu,colSf,colSb,colIf,colIb) local t hml hm cnum mscn pad padc ret waitmsg waitmsg = " ... press any key to continue " ' x=len(waitmsg) ' message "x) is:"&str(x) if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border ' screen print hml 1 colIb bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for if blen < 31 blen = 31 end if c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if screen save r1 c1 r2+2 c2+pad psa 'NEW ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad colSf colSb screen print r2+1 c2+pad-31 colSf colSb waitmsg pc=1 for c=1 to pl screen print c+r1 lc colSf colSb plist[c,2] end for if msg > null screen print r2+2 c1 colIf colIb str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 ' screen print r1+c lc colIf colIb plist[rec,2] drows = pl screen save r1 c1 r2+2 c2+1+pad dsa ' screen shortrestore mscn ' screen shortrestore psa clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ' inchar return (0) end if end function 'colpopuplines() function findcolpop(r1,c1,br,list,msg,findstr,num,mnu,colSf,colSb,colIf,colIb) local t hml hm cnum mscn pad padc ret if chkstr(findstr,list) = -1 return (-5) ' str to find is not in list end if if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 colIb bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad colSf colSb pc=1 for c=1 to pl screen print c+r1 lc colSf colSb plist[c,2] end for if msg > null screen print r2+2 c1 colIf colIb str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc colIf colIb plist[rec,2] drows = pl screen print r1+c lc colSf colSb plist[rec,2] while true ret=trim(plist[rec,2]) if ret = findstr screen print r1+c lc colIf colIb plist[rec,2] exit while else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) colSf colSb 1 end if c= case c (pl,c) else (c+1) rec=rec+1 continue while end if end while while TRUE k=inchar screen print r1+c lc colSf colSb plist[rec,2] if plist[rec,1]=1 screen print r1+c sc colSf colSb sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) colSf colSb 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) colSf colSb 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc colIf colIb plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc colIf colIb plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc colIf colIb sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) return (0) end if end function 'findcolpop() FUNCTION findpopup(r1,c1,br,list,findstr,msg,num,mnu) local t hml hm cnum mscn pad padc ret ' colpopup(r1,c1,br,list,msg,num,mnu,colSf,colSb) colSf = fgp colSb = bgp if chkstr(findstr,list) = -1 message "String is NOT in list" return (-5) ' str to find is not in list end if if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad fgp bgp pc=1 for c=1 to pl screen print c+r1 lc fgp bgp plist[c,2] end for if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] drows = pl screen print r1+c lc fgp bgp plist[rec,2] while true ret=trim(plist[rec,2]) if ret = findstr screen print r1+c lc fgi bgi plist[rec,2] exit while else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 continue while end if end while while TRUE k=inchar screen print r1+c lc fgp bgp plist[rec,2] if plist[rec,1]=1 screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) return (0) end if end function 'findpopup() function popuplist(r1,c1,br,list,msg,num,mnu) local t hml hm cnum mscn pad padc ret colSf = fgp colSb = bgp if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad fgp bgp pc=1 for c=1 to pl screen print c+r1 lc fgp bgp plist[c,2] end for ' > null if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] ' screen clear box r1 c1 r2+1 c2+pad fgp bgp screen save r1 c1 r2+1 c2+pad psa 'ORIGINAL drows = pl while TRUE k=inchar screen print r1+c lc fgp bgp plist[rec,2] if plist[rec,1]=1 screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} for c=recs to 1 step -1 if plist[c,1]=1 ret=ret & trim(plist[c,2]) end if end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa nr = c clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) ptval = nr return (0) end if end function 'popuplist() FUNCTION fentrybox(msg,elen,msk,dfalt) local tgt lmsg mbox r1 r2 c1 c2 c3 c4 errscn ptstr = NULL tgt = BLANK lmsg=len(msg) mbox = scrwidth if (lmsg+4) > scrwidth return (-2) end if ' message "sch is:"&str(sch) ' message "scr is:"&str(scr) r1 = scr-4 r2 = scr+2 ' message "r1) is:"&str(r1) if lmsg >= elen c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 c2 = c3 + lmsg + 1 c1 = c3-2 else c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 if c4 < 3 c4 = 3 end if c2 = c4 + elen + 1 if c2 > scrwidth c2 = scrwidth end if c1 = c4-2 end if if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if ' ############## New for SHADE ############################## ' screen save r1 c1 r2+1 c2+1 psa 'NEW screen save r1 c1 r2 c2 psa 'WAS ' SCREEN SAVE r1+1 c1+1 r2+1 c2+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2 c2 fgp bgp screen print r1+2 c3 fgp bgp msg if exact(msk,NULL)=FALSE screen input scr c4 fgi bgi elen tgt MASK msk dfalt else if dfalt = NULL screen input scr c4 fgi bgi elen tgt else screen input scr c4 fgi bgi elen tgt dfalt end if end if screen save r1 c1 r2 c2 dsa screen shortrestore psa if tgt = BLANK ptstr = NULL return (-1) else ptstr = str(tgt) return (0) end if END FUNCTION 'fentrybox() FUNCTION colfentbox(msg,elen,msk,dfalt,cf,cb) local tgt lmsg mbox r1 r2 c1 c2 c3 c4 errscnl fc2 bc2 fc1 bc1 k err ' cf=foreground color ' cb=background color ' e=allow escape from "q" filter ' err = 0 ' k=0 fc1=cf bc1=cb fc2=cf bc2=cb ptstr = NULL tgt = BLANK lmsg=len(msg) mbox = scrwidth if (lmsg+4) > scrwidth return (-2) end if r1 = scr-4 r2 = scr+2 if lmsg >= elen c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 c2 = c3 + lmsg + 1 c1 = c3-2 else c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 if c4 < 3 c4 = 3 end if c2 = c4 + elen + 1 if c2 > scrwidth c2 = scrwidth end if c1 = c4-2 end if if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print r1+2 c3 fc2 bc2 msg if exact(msk,NULL)=FALSE screen input scr c4 fgi bgi elen tgt MASK msk dfalt else if dfalt = NULL screen input scr c4 fgi bgi elen tgt else screen input scr c4 fgi bgi elen tgt dfalt end if end if screen save r1 c1 r2 c2 dsa screen shortrestore psa if tgt = BLANK ptstr = NULL return (-1) else ptstr = str(tgt) return (0) end if END FUNCTION 'colfentbox() FUNCTION redfentry(msg,elen,msk,dfalt) local tgt lmsg mbox r1 r2 c1 c2 c3 c4 errscn ptstr = NULL tgt = BLANK lmsg=len(msg) mbox = scrwidth if (lmsg+4) > scrwidth return (-2) end if r1 = scr-4 r2 = scr+2 if lmsg >= elen c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 c2 = c3 + lmsg + 1 c1 = c3-2 else c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 if c4 < 3 c4 = 3 end if c2 = c4 + elen + 1 if c2 > scrwidth c2 = scrwidth end if c1 = c4-2 end if if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fge bge screen print r1+2 c3 fge bge msg if exact(msk,NULL)=FALSE screen input scr c4 fgi bgi elen tgt MASK msk dfalt else if dfalt = NULL screen input scr c4 fgi bgi elen tgt else screen input scr c4 fgi bgi elen tgt dfalt end if end if screen save r1 c1 r2 c2 dsa screen shortrestore psa if tgt = BLANK ptstr = NULL return (-1) else ptstr = str(tgt) return (0) end if END FUNCTION 'redfentry() function messbox(msg,q,c,e) 'D. Lynn ' msg=message q=filter for yes/no (0=no filter,1=filter) ' c=color (0=error colors, 1=pleasing) e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err ' message "fgp) is:"&str(fgp) err = 0 k=0 if c=0 fc1=fge bc1=bge fc2=fge bc2=bge else fc1=fgp bc1=bgp fc2=fgi bc2=bgi end if ' message "fc1) is:"&str(fc1) ' message "bc1) is:"&str(bc1) ' message "fc2) is:"&str(fc2) ' message "bc2) is:"&str(bc2) mbox = scrwidth ' message "scr is:"&str(scr) lmsg=len(msg) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if ' repaint on ' repaint ' single-step on screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr c3 fc2 bc2 msg screen save r1 c1 r2 c2 dsa if q=0 wait 2 else WHILE "yn" !! k locate scr (c3+lmsg) 1 k=inchar if e=0 and k={Esc} err = -1 exit while end if k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 end if screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'messbox() ' function messbox(msg,q,c,e) 'D. Lynn ' ' msg=message q=filter for yes/no (0=no filter,1=filter) ' ' c=color (0=error colors, 1=pleasing) e=allow escape from "q" filter ' local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err ' err = 0 ' k=0 ' if c=0 ' fc1=fge ' bc1=bge ' fc2=fge ' bc2=bge ' else ' fc1=fgp ' bc1=bgp ' fc2=fgi ' bc2=bgi ' end if ' mbox = scrwidth ' lmsg=len(msg) ' if lmsg + 4 > scrwidth ' return (-2) ' end if ' r1 = scr-2 ' r2 = scr+2 ' c3 = int((mbox-lmsg)/2)+1 ' c1 = c3-2 ' c2 = c3+lmsg+1 ' if c1 <= 0 ' c1 = 1 ' end if ' if (c1-1) < 12 ' while (c1-1) < (scrwidth-c2) ' c2=c2+1 ' end while ' end if ' if c2 > scrwidth ' return (-2) ' end if ' ' screen clear box r1 c1 r2 c2 fc1 bc1 ' screen print scr c3 fc2 bc2 msg ' screen save r1 c1 r2 c2 dsa ' if q=0 ' wait 2 ' else ' WHILE "yn" !! k ' locate scr (c3+lmsg) 1 ' k=inchar ' if e=0 and k={Esc} ' err = -1 ' exit while ' end if ' k = lower(chr(k)) ' END WHILE ' locate scr (c3+lmsg) 0 ' end if ' screen shortrestore psa ' if k = 0 ' ptstr = NULL ' else ' ptstr = k ' end if ' return (err) ' end function 'messbox() function messboxNOSH(msg,q,c,e) 'D. Lynn ' msg=message q=filter for yes/no (0=no filter,1=filter) ' c=color (0=error colors, 1=pleasing) e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err err = 0 k=0 if c=0 fc1=fge bc1=bge fc2=fge bc2=bge else fc1=fgp bc1=bgp fc2=fgi bc2=bgi end if mbox = scrwidth lmsg=len(msg) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if ' message "base is:"&str(base) if base = "S" else ' ############## New for SHADE ############################## screen save r1 c1 r2 c2 psa 'WAS ' screen save r1 c1 r2+1 c2+1 psa 'NEW ' SCREEN SAVE r1+1 c1+1 r2+1 c2+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### end if screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr c3 fc2 bc2 msg screen save r1 c1 r2 c2 dsa if q=0 wait 2 else WHILE "yn" !! k locate scr (c3+lmsg) 1 k=inchar if e=0 and k={Esc} err = -1 exit while end if k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 end if screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'messbox() function messboxwait(msg,q,c,e) 'D. Lynn ' msg=message q=filter for yes/no (0=no filter,1=filter) ' c=color (0=error colors, 1=pleasing) e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 c4 lmsg mbox k err waitmsg waitmsg = " ... press any key to continue " err = 0 k=0 if c=0 fc1=fge bc1=bge fc2=fge bc2=bge else fc1=fgp bc1=bgp fc2=fgi bc2=bgi end if mbox = scrwidth lmsg=len(msg) if lmsg < 30 c4 = int((30-lmsg)/2)+1 msg = repeat("ÿ",c4)|msg|repeat("ÿ",c4) end if lmsg=len(msg) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if ' ############## New for SHADE ############################## ' screen save r1 c1 r2+1 c2+1 psa 'NEW screen save r1 c1 r2 c2 psa 'WAS ' SCREEN SAVE r1+1 c1+1 r2+1 c2+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### ' screen clear box r1 c1 r2 c2 fc1 bc1 ' screen print scr c3 fc2 bc2 msg ' screen save r1 c1 r2 c2 dsa ' screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr c3 fc2 bc2 msg screen print r2 c2-31 fc1 bc1 waitmsg screen save r1 c1 r2 c2 dsa if q=0 inchar else WHILE "yn" !! k locate scr (c3+lmsg) 1 k=inchar if e=0 and k={Esc} err = -1 exit while end if k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 end if screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'messboxwait() function keybox(lst,msg) local i t pr tlst l1 l2 mb r1 c1 r2 c2 c3 c4 mc klst c cp dc k '----------------------------------------------------------------- 'i = counter 'pr = user prompt 'r1 = calculated start row for box / together: 'c1 = calculated start column for box \ upper left corner 'r2 = calculated end row for box / together: 'c2 = calculated end column for box \ lower right corner 'c3 = calculated prompt print column (analysis only) 'c4 = calculated choices print column 'dc = delta c1,c2 'lst = passed string group of hot key position|selection item 'msg = message passed as string 'klst = a constructed hot key list 'm = maximum string length 't = target string in lst 'cp = passed hot key position for target string 'n = number of target strings (selection items) & rows 'k = key pressed '----------------------------------------------------------------- pr = "Select, or press Esc:" ptstr = NULL tlst = NULL klst = NULL l1 = len(pr) i = 1 while TRUE c = value(group(lst,i)) t = mid(group(lst,i),len(str(c))+1) if c > len(t) ptstr = "keybox():"&str(chr(34))|mid(group(lst,i),2)|str(chr(34))|", is not"& str(c) & "characters in length" return (-2) end if if c = 0 if t = NULL exit while else ptstr = "keybox(): no hot key defined for"&str(chr(34))|group(lst,i)|str(chr(34))|", item#"& str(i) return (-3) end if end if if lower(klst) ! lower(mid(t,c,1)) ptstr = "HOT Key duplication:"&"keybox("|str(chr(34)) \ |t& \ mid(group(lst,match(lower(klst),lower(mid(t,c,1)))),2) \ |str(chr(34))| \ ") for ->"&str(chr(34))|mid(t,c,1)|str(chr(34)) return (-4) else tlst=tlst&t klst=klst|mid(t,c,1) i=i+1 end if end while tlst = trim(tlst) l2 = len(tlst) mb = scrwidth c3 = int((mb-len(pr))/2) + 1 c4 = int((mb-len(tlst))/2) + 1 if l2 >= l1 c2 = c4 + len(tlst) + 1 c1 = c4 - 2 else c2 = c3 + len(pr) + 1 c1 = c3 - 2 end if r1 = scr-2 r2 = scr+2 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth ptstr = "keybox():"&str(r1)&str(c1)&str(r2)&str(c2)&"outside of screen dimensions!" return (-5) end if dc = c2-c1 screen save r1-1 c1 r2+1 c2 psa screen clear box r1 c1 r2 c2 fgp bgp screen print scr c4 fgp bgp tlst screen print r1-1 c1 fgi bgi str(format(pr,"M"|str(dc+1))) if msg > null screen print r2+1 c1 fgi bgi str(format(left(msg,dc+1),"M"|str(dc+1))) end if i = 1 while TRUE t = group(tlst,i) if t = NULL exit while end if c = mid(klst,i,1) cp = value(group(lst,i)) screen print scr c4+cp-1 fgi bgi c c4=c4+len(t)+1 i=i+1 end while k = NULL while lower(klst) !! lower(k) key name inchar k if k = "Esc" k = NULL exit while end if end while screen save r1-1 c1 r2+1 c2 dsa screen shortrestore psa if k = NULL return (-1) else ptstr = lower(k) return (0) end if end function function vkeybox(r1,c1,lst,msg) local klst i m t cp ch[20,6] n r2 c2 k dc '----------------------------------------------------------------- 'r1 = passed start row for box / together: 'c1 = passed start column for box \ upper left corner 'lst = passed string group of hot key position|selection item 'msg = message passed as string 'klst = a constructed hot key list 'i = counter 'm = maximum string length 't = target string in lst 'cp = passed hot key position for target string 'ch[] = array used for display of box contents 'ch[i,1] = target string (selection item) 'ch[i,2] = " " display row 'ch[i,3] = " " display column 'ch[i,4] = " " hot key 'ch[i,5] = " " hot key display row 'ch[i,6] = " " hot key display column 'n = number of target strings (selection items) & rows 'r2 = calculated end row for box / together: 'c2 = calculated end column for box \ lower right corner 'dc = delta c1,c2 'k = key pressed '----------------------------------------------------------------- ptstr = NULL klst=NULL i = 1 m = 0 while true t = group(lst,i) if exact(t,NULL) = TRUE exit while end if cp = value(t) t = mid(t,len(str(cp))+1) ch[i,1] = t ch[i,2] = r1+i ch[i,3] = c1+2 ch[i,4] = mid(t,cp,1) ch[i,5] = ch[i,2] ch[i,6] = ch[i,3]+cp-1 if cp > len(t) ptstr = "vkeybox():"&str(chr(34))|mid(group(lst,i),2)|str(chr(34))|", is not"& str(cp) & "characters in length" return (-2) elseif cp = 0 ptstr = "vkeybox(): no hot key defined for"&str(chr(34))|group(lst,i)|str(chr(34))|", item#"& str(i) return (-3) end if if lower(klst) ! lower(ch[i,4]) ptstr = "HOT Key duplication:"&"vkeybox("|str(chr(34))|ch[i,1]&ch[match(lower(klst),lower(ch[i,4])),1]|str(chr(34))|") for ->"&str(chr(34))|ch[i,4]|str(chr(34)) return (-4) else klst = klst|ch[i,4] end if if len(t) > m m=len(t) end if i=i+1 end while n = i-1 r2 = r1+n+1 c2 = c1+m+3 dc = c2-c1 if r2 > scrheight or c2 > scrwidth ptstr = "vkeybox():"&str(r1)&str(c1)&str(r2)&str(c2)&"outside of screen dimensions!" return (-5) end if screen save r1 c1 r2+1 c2 psa screen clear box r1 c1 r2 c2 fgp bgp for i = 1 to n step 1 screen print ch[i,2] ch[i,3] fgp bgp ch[i,1] screen print ch[i,5] ch[i,6] fgi bgi ch[i,4] end for if msg > null screen print r2+1 c1 fgi bgi str(format(left(msg,dc+1),"M"|str(dc+1))) end if screen save r1 c1 r2+1 c2 dsa k = NULL while lower(klst) !! lower(k) key name inchar k if k = "Esc" k = NULL exit while end if end while screen shortrestore psa if k = NULL return (-1) else ptstr = lower(k) return (0) end if end function function mess4(msg1,msg2,msg3,msg4,msg5,$hdr) 'D.Cooper local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err q endmess cc rh1 a6 ch q = 1 err = 0 endmess = msg5 k=0 fc1=fgp bc1=bgp fc2=fgi bc2=bgi mbox = scrwidth lmsg=max(len(msg1),len(msg2),len(msg3),len(msg4),len(endmess)+2,len($hdr)+2) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-3 rh1 = scr-4 r2 = scr+4 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if cc = scrwidth/2-(len(endmess)/2)+1 if len($hdr)>0 ch = scrwidth/2-(len($hdr)/2)+1 a6 = format($hdr,"M"|lmsg+4) screen save rh1 c1 r2 c2 psa screen clear box rh1 c1 rh1 c2 fc1 bc1 no-border screen print rh1 ch fgp bgp a6 else screen save r1 c1 r2 c2 psa end if screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr-2 c3 fgp bgp msg1 screen print scr-1 c3 fgp bgp msg2 screen print scr c3 fgp bgp msg3 screen print scr+1 c3 fgp bgp msg4 screen print scr+3 cc fc2 bc2 endmess if len($hdr)>0 screen save rh1 c1 r2 c2 dsa else screen save r1 c1 r2 c2 dsa end if while "yn" !! k locate scr+3 (cc+len(endmess)-1) 1 k=inchar k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'mess4() function mess3(msg1,msg2,msg3,msg4) 'D.Cooper ' crib from messbox for multi line output to check/confirm local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err q cc endmess q = 1 err = 0 ' endmess = " Correct? (y/n) " endmess = msg4 k=0 fc1=fgp bc1=bgp fc2=fgi bc2=bgi mbox = scrwidth lmsg=max(len(msg1),len(msg2),len(msg3),len(endmess)+2) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-3 r2 = scr+3 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if cc = scrwidth/2-(len(endmess)/2)+1 screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr-2 c3 fgp bgp msg1 screen print scr-1 c3 fgp bgp msg2 screen print scr c3 fgp bgp msg3 screen print scr+2 cc fc2 bc2 endmess screen save r1 c1 r2 c2 dsa WHILE "yn" !! k locate scr+2 (cc+len(endmess)-1) 1 k=inchar k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'mess3() FUNCTION entryline(msg,elen,msk,dfalt,row1,col1,maxlen) local tgt lmsg mbox r1 r2 c1 c2 c3 c4 errscn ptstr = NULL tgt = BLANK lmsg=len(msg) mbox = maxlen if (lmsg+2) > maxlen message "Message too long for box" return (-2) end if if lmsg >= elen c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 c2 = c3 + lmsg + 1 c1 = c3-2 else c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 if c4 < 3 c4 = 3 end if c2 = c4 + elen + 1 if c2 > scrwidth c2 = scrwidth end if c1 = c4-2 end if if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if r1 = row1 c1 = col1 r2 = row1+1 c2 = col1+maxlen-1 screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fgp bgp no-border ' c3 = int((maxlen)/2 + c1 - (lmsg/2)) + 1 c3 = int((maxlen)/2 + c1 - (lmsg/2)) screen print r1 c3 fgp bgp msg if exact(msk,NULL)=FALSE ' c4 = int((maxlen)/2 + c1 - (elen/2)) + 1 c4 = int((maxlen)/2 + c1 - (elen/2)) screen input r1+1 c4 fgi bgi elen tgt MASK msk dfalt else if dfalt = NULL c4 = int((maxlen)/2 + c1 - (elen/2)) - 1 screen input r1+1 c4 fgi bgi elen tgt else c4 = int((maxlen)/2 + c1 - (elen/2)) - 1 screen input r1+1 c4 fgi bgi elen tgt dfalt end if end if screen shortrestore psa if tgt = BLANK ptstr = NULL return (-1) else ptstr = str(tgt) return (0) end if END FUNCTION 'entryline() FUNCTION messline(msg,q,c,e,row1,col1,maxlen) ' msg=message q=filter for yes/no (0=no filter,1=filter) ' c=color (0=error colors, 1=pleasing, 2=inverted) e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err xlen err = 0 k=0 if c=0 fc1=fge bc1=bge fc2=fge bc2=bge elseif c=1 fc1=fgp bc1=bgp fc2=fgi bc2=bgi else fc1=fgi bc1=bgi fc2=fgi bc2=bgi end if mbox = scrwidth lmsg=len(msg) if lmsg + 4 > scrwidth xlen = lmsg + 4 - scrwidth message "Message too long by"&str(xlen)&"spaces - UINTLIB line 1942" ' remove("longline.txt") fopen "longline.txt" as 1 fwrite 1 from msg fclose 1 return (-2) end if if maxlen > scrwidth message "maxlen greater than scrwidth" return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if r1 = row1 c1 = col1 r2 = row1 c2 = col1+maxlen-1 screen clear box r1 c1 r2 c2 fc1 bc1 'screen clear box r1 c1 r2 c2 fgp bgp c3 = int((maxlen)/2 + c1 - (lmsg/2)) - 1 screen print r1 c3 fc1 bc1 msg screen save r1 c1 r2 c2 dsa if q=0 wait 2 else WHILE "yn" !! k locate r1 (c3+lmsg) 1 k=inchar if e=0 and k={Esc} err = -1 exit while end if k = lower(chr(k)) END WHILE locate r1 (c3+lmsg) 0 end if 'screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) END FUNCTION 'messline(msg,q,c,e,row1,col1,maxlen) FUNCTION posnpopup(r1,c1,br,list,msg,num,mnu,linenr) local t hml hm cnum mscn pad padc ret colSf = fgp colSb = bgp if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad fgp bgp pc=1 for c=1 to pl screen print c+r1 lc fgp bgp plist[c,2] end for if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] drows = pl screen print r1+c lc fgp bgp plist[rec,2] while true if c = pl screen print r1+c lc fgi bgi plist[rec,2] exit while elseif c = linenr+1 screen print r1+c lc fgi bgi plist[rec,2] exit while else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 continue while end if end while while TRUE k=inchar screen print r1+c lc fgp bgp plist[rec,2] if plist[rec,1]=1 screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa nr = c clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) ptval = nr return (0) end if end function 'posnpopup() FUNCTION posncolpopup(r1,c1,br,list,msg,num,mnu,colSf,colSb,colIf,colIb,linenr) local t hml hm cnum mscn pad padc ret ' colSf = fgp ' colSb = bgp if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad fgp bgp pc=1 for c=1 to pl screen print c+r1 lc fgp bgp plist[c,2] end for if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] drows = pl screen print r1+c lc fgp bgp plist[rec,2] while true if c = pl screen print r1+c lc fgi bgi plist[rec,2] exit while elseif c = linenr+1 screen print r1+c lc fgi bgi plist[rec,2] exit while else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 continue while end if end while while TRUE k=inchar screen print r1+c lc fgp bgp plist[rec,2] if plist[rec,1]=1 screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa nr = c clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) ptval = nr return (0) end if end function 'posncolpopup() FUNCTION reqnpopup(r1,c1,br,list,msg,num,mnu,linenr,col1,col2) local t hml hm cnum mscn pad padc ret colSf = fgp colSb = bgp if exact(trim(list),NULL)=FALSE recs = uistrcnt(list) if recs = 0 return (-3) end if else return (-2) end if redimension plist[recs,3] smartpeek $_l1 hml if br-r1<1 return (-4) elseif br+1 > scrheight mr=scrheight-1 msg = "" else mr=br end if if br >= hml mnu = 0 end if screen save hml 1 hml scrwidth mscn if recs > scrheight if mnu = 1 screen clear box hml 1 hml scrwidth 0 0 no-border screen print hml 1 bgi bgs "Building list..." end if end if ptstr=NULL if mnu = 1 hm = case num (0,"Enter = select/unselect F10 = done Esc = exit") \ (1,"Enter = select Esc = exit (select: 1 item)") \ else "Enter = select/unselect F10 = done Esc = exit " & \ " (select up to:" & str(num) & "items)" else hm = NULL end if sym = spsymmap(28) cnum=0 blen=0 l=blen for c=1 to recs plist[c,2]=group(list,c) l=len(plist[c,2]) plist[c,1]=0 if l>blen blen=l end if end for c2=c1+blen+2 r2=r1+recs if r2>mr r2=mr end if dc=(c2-c1) lc=c1+1 pad = case num (1,1) else 2 sc=c1+pad-1 pl=(r2-r1) padc = repeat(chr(32),pad) for i = 1 to recs pc = 1 plist[i,2]=padc|format(plist[i,2],"l",dc-1) plist[i,3] = i if i = pl pc=pc+1 end if end for if recs > scrheight screen shortrestore mscn end if ' screen save r1 c1 r2+3 c2+pad+1 psa 'NEW screen save r1 c1 r2+2 c2+pad psa 'ORIGINAL ' ############## New for SHADE ############################## ' SCREEN SAVE r1+1 c1+1 r2+2 c2+pad+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2+1 c2+pad col1 col2 pc=1 for c=1 to pl ' screen print c+r1 lc fgp bgp plist[c,2] screen print c+r1 lc col1 col2 plist[c,2] end for if msg > null screen print r2+2 c1 fgi bgi str(format(left(msg,dc+pad+1),"M"|str(dc+pad+1))) end if if mnu = 1 screen clear box hml 1 hml scrwidth fgs bgs no-border screen print hml 1 fgs bgs (format(hm,"L"|str(scrwidth))) end if c=1 rec=1 screen print r1+c lc fgi bgi plist[rec,2] drows = pl ' screen print r1+c lc fgp bgp plist[rec,2] screen print r1+c lc col1 col2 plist[rec,2] while true if c = pl screen print r1+c lc fgi bgi plist[rec,2] exit while elseif c = linenr+1 screen print r1+c lc fgi bgi plist[rec,2] exit while else if c = pl ' screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) col1 col2 1 end if c= case c (pl,c) else (c+1) rec=rec+1 continue while end if end while while TRUE k=inchar ' screen print r1+c lc fgp bgp plist[rec,2] screen print r1+c lc col1 col2 plist[rec,2] if plist[rec,1]=1 screen print r1+c sc col1 col2 sym ' screen print r1+c sc fgp bgp sym end if if k={Down} if rec=recs if recs<=pl rec=1 c=1 else beep end if else if c = pl ' screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 screen scroll up r1+1 lc r2 (c2+case num (1,0) else 1) col1 col2 1 end if c= case c (pl,c) else (c+1) rec=rec+1 end if elseif k={Up} if rec=1 if recs <= pl rec = recs c = pl else beep end if else if c = 1 ' screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) fgp bgp 1 screen scroll down r1+1 lc r2 (c2+case num (1,0) else 1) col1 col2 1 end if c= case c (1,c) else (c-1) rec=rec-1 end if elseif k={Home} if c>1 if rec =(rec-c)+1 rec = 1 else rec =(rec-c)+1 end if c=1 else rec=1 c=1 end if elseif k={^Home} if rec = c rec = 1 c=1 else rec = 1 c=1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if elseif k={End} if rec < recs and c < pl if drows < pl rec = recs-pl+1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = recs c = pl else if rec+(pl-c) < recs rec = rec+(pl-c) c = pl else rec = recs c = pl end if end if end if elseif k={^End} rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs elseif k={PgDn} if rec = recs and c = pl beep elseif c <= pl if rec = recs or rec+pl >= recs rec = recs-pl+1 c = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) c = pl rec = recs else rec = rec+pl refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if end if elseif k={PgUp} if rec = 1 and c = 1 beep else if recs > pl if (rec-pl)-c <= 1 c = rec-pl if c < 1 c = 1 end if rec = 1 refresh(c,r1,c1,r2,c2,pad,colSf,colSb) rec = c else rec=(rec-pl) refresh(c,r1,c1,r2,c2,pad,colSf,colSb) end if else if rec > 1 rec=1 c=1 end if end if end if elseif k={Enter} screen print r1+c lc fgi bgi plist[rec,2] if num = 1 ret=trim(plist[rec,2]) exit while end if if plist[rec,1] = 1 if udelstr(trim(plist[rec,2]),ret) = 0 ret = ptstr end if plist[rec,1] = 0 cnum=cnum-1 else if cnum = num and not(num=0) beep else ret=trim(ret&plist[rec,2]) plist[rec,1] = 1 cnum=cnum+1 end if end if if rec < recs smartpoke $_key {Down} end if elseif k={Esc} ret=null exit while elseif k={F10} ' for c=recs to 1 step -1 ' if plist[c,1]=1 ' ret=ret & trim(plist[c,2]) ' end if ' end for exit while end if if k<> {Enter} screen print r1+c lc fgi bgi plist[rec,2] end if if plist[rec,1]=1 screen print r1+c sc fgi bgi sym end if end while screen save r1 c1 r2+2 c2+1+pad dsa screen shortrestore mscn screen shortrestore psa nr = c clear c k dc lc sc recs c2 r2 l blen pl mr pc sym pg i rec tr drows redimension plist[1,3] if trim(ret) = NULL ptstr = NULL return (-1) else ptstr = trim(ret) ptval = nr return (0) end if end function 'reqnpopup() function refresh(z,r1,c1,r2,c2,pad,b1,b2) local x t screen clear box r1 c1 r2+1 c2+pad b1 b2 drows = 0 for x=0 to pl-1 t = rec-z+x+1 if t > recs exit for else if t > 0 screen print x+1+r1 lc b1 b2 plist[t,2] drows=drows+1 if plist[t,1]=1 screen print x+1+r1 sc b1 b2 sym end if end if end if end for end function 'refresh() FUNCTION chkstr(s,sl) local t i '------------------------------------- 's = string to check 'sl = string group 't = targeted item to check 'i = counter for group() function '------------------------------------- 'returns TRUE = item is in string group ' FALSE = item is not in list '------------------------------------- i=0 while exact(t,NULL)=FALSE i=i+1 t = group(sl,i) if t = s return (0) end if end while return (-1) end function 'chkstr() function uistrcnt(sl) local i s lo hi c '------------------------------------- 'sl = string group 'i = counter for group() function 's = string counter increment 'lo = low search record 'hi = high search record 'c = temporary equation to find NULL '------------------------------------- 'returns count of strings in string ' group '------------------------------------- s=20 while exact(group(sl,s),NULL)=FALSE s=s+20 end while hi = s lo = 1 while lo <= hi i = int((lo+hi)/2) c = group(sl,i) if c = NULL hi = i-1 else lo = i+1 end if end while while (exact(group(sl,i),NULL)=TRUE and i>0) i=i-1 end while return (i) end function 'uistrcnt() function udelstr(s,sl) local t i n f '------------------------------------- 's = string to check 'sl = string group 't = targeted string to check 'i = counter for group() function 'n = new string group 'f = list changed flag '------------------------------------- 'returns: success = list less item ' failure = original list '------------------------------------- f=0 i=0 n=NULL ptstr = NULL while TRUE i=i+1 t = group(sl,i) if exact(t,NULL)=TRUE exit while elseif t = s f=1 else n=n&t end if end while if f = 1 ptstr = trim(n) return (0) end if ptstr = sl return (-1) end function 'udelstr() function colmessbox(msg,q,cf,cb,e) 'D. Lynn ' msg=message q=filter for yes/no (0=no filter,1=filter) ' cf=foreground color ' cb=background color ' e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err err = 0 k=0 fc1=cf bc1=cb fc2=cf bc2=cb mbox = scrwidth lmsg=len(msg) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr c3 fc2 bc2 msg screen save r1 c1 r2 c2 dsa if q=0 wait 2 else WHILE "yn" !! k locate scr (c3+lmsg) 1 k=inchar if e=0 and k={Esc} err = -1 exit while end if k = lower(chr(k)) END WHILE locate scr (c3+lmsg) 0 end if screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'colmessbox() FUNCTION entrylineCONV(msg,elen,msk,dfalt,row1,col1,maxlen) local tgt lmsg mbox r1 r2 c1 c2 c3 c4 errscn ptstr = NULL tgt = BLANK lmsg=len(msg) mbox = maxlen if (lmsg+2) > maxlen message "Message too long for box" return (-2) end if if lmsg >= elen c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 c2 = c3 + lmsg + 1 c1 = c3-2 else c3 = int((mbox-lmsg)/2)+1 c4 = int((mbox-elen)/2)+1 if c4 < 3 c4 = 3 end if c2 = c4 + elen + 1 if c2 > scrwidth c2 = scrwidth end if c1 = c4-2 end if if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if r1 = row1 c1 = col1 r2 = row1+1 c2 = col1+maxlen-1 ' screen save r1 c1 r2 c2 psa screen clear box r1 c1 r2 c2 fgp bgp no-border ' c3 = int((maxlen)/2 + c1 - (lmsg/2)) + 1 c3 = int((maxlen)/2 + c1 - (lmsg/2)) screen print r1 c3 fgp bgp msg if exact(msk,NULL)=FALSE ' c4 = int((maxlen)/2 + c1 - (elen/2)) + 1 c4 = int((maxlen)/2 + c1 - (elen/2)) screen input r1+1 c4 fgi bgi elen tgt MASK msk dfalt else if dfalt = NULL c4 = int((maxlen)/2 + c1 - (elen/2)) - 1 screen input r1+1 c4 fgi bgi elen tgt else c4 = int((maxlen)/2 + c1 - (elen/2)) - 1 screen input r1+1 c4 fgi bgi elen tgt dfalt end if end if ' screen shortrestore psa if tgt = BLANK ptstr = NULL return (-1) else ptstr = str(tgt) return (0) end if END FUNCTION 'entrylineCONV() function flashmess(msg,q,c,e) ' msg=message q=filter for yes/no (0=no filter,1=filter) ; i=interval ' c=color (0=error colors, 1=pleasing) e=allow escape from "q" filter local fc2 bc2 fc1 bc1 r1 r2 c1 c2 c3 lmsg mbox k err err = 0 k=0 if c=0 fc1=fge bc1=bge fc2=fge bc2=bge else fc1=fgp bc1=bgp fc2=fgi bc2=bgi end if mbox = scrwidth lmsg=len(msg) if lmsg + 4 > scrwidth return (-2) end if r1 = scr-2 r2 = scr+2 c3 = int((mbox-lmsg)/2)+1 c1 = c3-2 c2 = c3+lmsg+1 if c1 <= 0 c1 = 1 end if if (c1-1) < 12 while (c1-1) < (scrwidth-c2) c2=c2+1 end while end if if c2 > scrwidth return (-2) end if ' ############## New for SHADE ############################## ' screen save r1 c1 r2+1 c2+1 psa 'NEW screen save r1 c1 r2 c2 psa 'ORIGINAL ' SCREEN SAVE r1+1 c1+1 r2+1 c2+1 $screen 'NEW ' _shade() 'NEW ' SCREEN SHORTRESTORE $screen 'NEW ' ############## END of New for SHADE ####################### screen clear box r1 c1 r2 c2 fc1 bc1 screen print scr c3 fc2 bc2 msg screen save r1 c1 r2 c2 dsa wait .5 screen shortrestore psa if k = 0 ptstr = NULL else ptstr = k end if return (err) end function 'flashmess()