home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1993 #2 / Image.iso / clipper / gets87.zip / GETS87S.PRG < prev   
Text File  |  1993-05-01  |  4KB  |  132 lines
  1. /******************************************************************
  2. *  GETS87S.PRG --- Provide S'87 style scrolling windows for
  3. *  character fields.
  4. *  This is an original work by Ronald Bass [75060,3371],
  5. *  and is placed in the public domain.
  6. *  Compile this .prg using
  7. *                 CLIPPER GETS87S /n/w
  8. *
  9. *  and include GETS87S.OBJ in the link script.
  10. *
  11. *  Add the line
  12. *    #include "gets87s.ch"
  13. *  in any .prg that uses this function.
  14. *
  15. *  The demonstration of this function can be compiled using
  16. *                 CLIPPER GETS87S /n/w/dDEMO
  17. *                 RTLINK FI GETS87S
  18. */
  19. #ifdef DEMO
  20. #include "Set.ch"
  21. #include "Inkey.ch"
  22. #include "Getexit.ch"
  23. #include "gets87s.ch"
  24.  
  25. #define K_UNDO          K_CTRL_U
  26.  
  27. procedure main
  28.  
  29. local first, second, getlist := {}
  30. first := space(30)
  31. second := space(40)
  32. setcolor( "W+/B,W+/BG,,,W+/R" )
  33.  
  34. DO WHILE LASTKEY() # 27
  35.   cls
  36.   @ 10, 10 SAY "Edit 30 char string..." GET first;
  37.     PICTURE "@S10" //SEND reader := {|g| rgetreader(g)}
  38.   @ 12, 10 SAY "Edit 40 char string..." GET second ;
  39.     PICTURE "@s20" //SEND reader := {|g| rgetreader(g)}
  40.   READ
  41.   @ 18,10 SAY "Press <Esc> to end, any other key to continue..."
  42.   inkey(0)
  43. ENDDO
  44.  
  45. return
  46.  
  47. #endif
  48.  
  49.  
  50. /***
  51. *       rGetReader()
  52. *       Revised Standard modal read of a single GET.
  53. */
  54. proc rGetReader( get )
  55.  
  56. local grow, gcol, gpicture := upper( get:picture ), gcolor
  57. local gpos, gwin, gdoit := .f.
  58. local wpos := 1, wstart := 1, wlen, gmove
  59.  
  60.  
  61.     // read the GET if the WHEN condition is satisfied
  62.     if ( GetPreValidate(get) )
  63.  
  64.         // activate the GET for reading
  65.         get:SetFocus()
  66.                 if gpicture # nil .and. '@S' $ gpicture
  67.                   gdoit := .t.
  68.                   grow := get:row
  69.                   gcol := get:col
  70.                   gpos := get:pos
  71.                   gpicture := substr( gpicture, at('@S',gpicture)+2 )
  72.                   // pick out the length of the window
  73.                   wlen := val( gpicture )
  74.  
  75.                   // move the active get off the screen
  76.                   get:row := maxrow() + 1
  77.  
  78.                   //get:display()
  79.                   gcolor := setcolor( substr( get:colorSpec,;
  80.                               at(',',get:colorSpec)+1 ) )
  81.                 endif
  82.  
  83.         while ( get:exitState == GE_NOEXIT )
  84.  
  85.             // check for initial typeout (no editable positions)
  86.             if ( get:typeOut )
  87.                 get:exitState := GE_ENTER
  88.             end
  89.  
  90.             // apply keystrokes until exit
  91.             while ( get:exitState == GE_NOEXIT )
  92.                                 GetApplyKey( get, Inkey(0) )
  93.                                 if gdoit
  94.                                   gmove := get:pos - gpos
  95.                                   gpos := get:pos
  96.                                   if gmove + wpos < 1
  97.                                     wstart += wpos + gmove - 1
  98.                                     wpos := 1
  99.                                   else
  100.                                     if gmove + wpos > wlen
  101.                                       wstart += wpos + gmove -wlen
  102.                                       wpos := wlen
  103.                                     else
  104.                                       wpos += gmove
  105.                                     endif
  106.                                   endif
  107.                                   @ grow, gcol SAY substr( get:buffer,;
  108.                                   wstart, wlen )
  109.                                   setpos( grow, gcol + wpos -1 )
  110.                                 endif
  111.             end
  112.  
  113.             // disallow exit if the VALID condition is not satisfied
  114.             if ( !GetPostValidate(get) )
  115.                 get:exitState := GE_NOEXIT
  116.             end
  117.  
  118.         end
  119.  
  120.         // de-activate the GET
  121.                 if gdoit
  122.                   get:row := grow
  123.                   setcolor( gcolor )
  124.                 endif
  125.         get:KillFocus()
  126.  
  127.     end
  128. //@ 22,0 clear to 22,79
  129. return
  130.  
  131.  
  132.