home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
C!T ROM 2
/
ctrom_ii_b.zip
/
ctrom_ii_b
/
PROGRAM
/
CLIPPER
/
GETS87
/
GETS87S.PRG
< prev
Wrap
Text File
|
1993-05-01
|
4KB
|
132 lines
/******************************************************************
* GETS87S.PRG --- Provide S'87 style scrolling windows for
* character fields.
* This is an original work by Ronald Bass [75060,3371],
* and is placed in the public domain.
* Compile this .prg using
* CLIPPER GETS87S /n/w
*
* and include GETS87S.OBJ in the link script.
*
* Add the line
* #include "gets87s.ch"
* in any .prg that uses this function.
*
* The demonstration of this function can be compiled using
* CLIPPER GETS87S /n/w/dDEMO
* RTLINK FI GETS87S
*/
#ifdef DEMO
#include "Set.ch"
#include "Inkey.ch"
#include "Getexit.ch"
#include "gets87s.ch"
#define K_UNDO K_CTRL_U
procedure main
local first, second, getlist := {}
first := space(30)
second := space(40)
setcolor( "W+/B,W+/BG,,,W+/R" )
DO WHILE LASTKEY() # 27
cls
@ 10, 10 SAY "Edit 30 char string..." GET first;
PICTURE "@S10" //SEND reader := {|g| rgetreader(g)}
@ 12, 10 SAY "Edit 40 char string..." GET second ;
PICTURE "@s20" //SEND reader := {|g| rgetreader(g)}
READ
@ 18,10 SAY "Press <Esc> to end, any other key to continue..."
inkey(0)
ENDDO
return
#endif
/***
* rGetReader()
* Revised Standard modal read of a single GET.
*/
proc rGetReader( get )
local grow, gcol, gpicture := upper( get:picture ), gcolor
local gpos, gwin, gdoit := .f.
local wpos := 1, wstart := 1, wlen, gmove
// read the GET if the WHEN condition is satisfied
if ( GetPreValidate(get) )
// activate the GET for reading
get:SetFocus()
if gpicture # nil .and. '@S' $ gpicture
gdoit := .t.
grow := get:row
gcol := get:col
gpos := get:pos
gpicture := substr( gpicture, at('@S',gpicture)+2 )
// pick out the length of the window
wlen := val( gpicture )
// move the active get off the screen
get:row := maxrow() + 1
//get:display()
gcolor := setcolor( substr( get:colorSpec,;
at(',',get:colorSpec)+1 ) )
endif
while ( get:exitState == GE_NOEXIT )
// check for initial typeout (no editable positions)
if ( get:typeOut )
get:exitState := GE_ENTER
end
// apply keystrokes until exit
while ( get:exitState == GE_NOEXIT )
GetApplyKey( get, Inkey(0) )
if gdoit
gmove := get:pos - gpos
gpos := get:pos
if gmove + wpos < 1
wstart += wpos + gmove - 1
wpos := 1
else
if gmove + wpos > wlen
wstart += wpos + gmove -wlen
wpos := wlen
else
wpos += gmove
endif
endif
@ grow, gcol SAY substr( get:buffer,;
wstart, wlen )
setpos( grow, gcol + wpos -1 )
endif
end
// disallow exit if the VALID condition is not satisfied
if ( !GetPostValidate(get) )
get:exitState := GE_NOEXIT
end
end
// de-activate the GET
if gdoit
get:row := grow
setcolor( gcolor )
endif
get:KillFocus()
end
//@ 22,0 clear to 22,79
return