home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 5 / 05.iso / a / a054 / 1.img / GETPRGS.EXE / GETS08.PRG < prev    next >
Encoding:
Text File  |  1992-03-08  |  4.6 KB  |  188 lines
  1. // Gets08.prg
  2. //
  3. // Example illustrating issuing gets from database
  4. // Save in our own array of GET objects - edit to memvars
  5. // Use cargo as dictionary
  6. // Use WHEN clause as .F. if say without GET - otherwise have GET
  7. // on NULL field which is bad
  8. // Use translate to access cargo
  9. // Implement user priveledges + name
  10.  
  11. #include "Inkey.ch"
  12.  
  13. #define COMPILE(c) &("{||" + c + "}")
  14.  
  15. #xtranslate SAY_ROW(<o>)        => DictAt(<o>:cargo,  "Say Row")
  16. #xtranslate SAY_ROW(<o>,<n>)    => DictPutPair(<o>:cargo, {"Say Row", <n>})
  17.  
  18. #xtranslate SAY_COL(<o>)        => DictAt(<o>:cargo,  "Say Col")
  19. #xtranslate SAY_COL(<o>,<n>)    => DictPutPair(<o>:cargo, {"Say Col", <n>})
  20.  
  21. #xtranslate SAY_STRING(<o>)     => DictAt(<o>:cargo,  "Say String")
  22. #xtranslate SAY_STRING(<o>,<c>) => DictPutPair(<o>:cargo, {"Say String", <c>})
  23.  
  24. #xtranslate SAY_PICT(<o>)       => DictAt(<o>:cargo,  "Say Pict")
  25. #xtranslate SAY_PICT(<o>, <c>)  => DictPutPair(<o>:cargo, {"Say Pict", <c>})
  26.  
  27. #xtranslate SAY_COLOR(<o>)      => DictAt(<o>:cargo,  "Say Color")
  28. #xtranslate SAY_COLOR(<o>, <c>) => DictPutPair(<o>:cargo, {"Say Color", <c>})
  29.  
  30. #xtranslate GET_BLOCK(<o>)      => DictAt(<o>:cargo,  "Get Block")
  31. #xtranslate GET_BLOCK(<o>, <b>) => DictPutPair(<o>:cargo, {"Get Block", <b>})
  32.  
  33. #xtranslate GET_VALUE(<o>)      => DictAt(<o>:cargo,  "Get Value")
  34. #xtranslate GET_VALUE(<o>, <x>) => DictPutPair(<o>:cargo, {"Get Value", <x>})
  35.  
  36. FUNCTION Gets08
  37.  
  38. FIELD ScrName, FldNum
  39. LOCAL aScreen1, aScreen2
  40. LOCAL cUserPriv := "ade"
  41.  
  42.   CLEAR SCREEN
  43.    
  44.   USE Screens NEW
  45.   IF !File("Screens.ntx")
  46.     INDEX ON Upper(ScrName) + Str(FldNum, 3) TO Screens
  47.   ELSE
  48.     SET INDEX TO Screens
  49.   ENDIF
  50.   USE Test NEW SHARED
  51.  
  52.   SET KEY K_F2 TO test
  53.   aScreen1 := BuildScreen("TEST", cUserPriv)
  54.   ReadScreen(aScreen1)
  55.  
  56.   cUserPriv := "b"
  57.   aScreen1 := BuildScreen("TEST", cUserPriv)
  58.   ReadScreen(aScreen1)
  59.  
  60.   aScreen2 := BuildScreen("TEST1", cUserPriv)
  61.   ReadScreen(aScreen2)
  62.  
  63.   ReadScreen(aScreen1)
  64.  
  65. RETURN NIL
  66.  
  67.  
  68. FUNCTION BuildScreen(cScrName, cUserPriv)
  69.  
  70. FIELD ScrName, SayRow, SayCol, SayString, ;
  71.       SayPict, SayColor IN Screens
  72.  
  73. FIELD GetRow,  GetCol, GetFld, GetPict, ;
  74.       GetWhen, GetValid, GetColor, GetPriv, GetName IN Screens
  75.  
  76. LOCAL nGets  := 0
  77. LOCAL i
  78. LOCAL aGets := {}
  79. LOCAL oGet
  80.  
  81.   Screens -> (DbSeek(cScrName))
  82.   DO WHILE cScrName == Trim(Upper(Screens -> ScrName))
  83.     IF GetPriv $ cUserPriv
  84.       nGets++
  85.       Aadd(aGets, GetNew())
  86.       oGet := aGets[nGets]
  87.       oGet:cargo := DictNew()
  88.       SAY_ROW(oGet, SayRow)
  89.       SAY_COL(oGet, SayCol)
  90.       SAY_STRING(oGet, Trim(SayString))
  91.       SAY_PICT(oGet, Trim(SayPict))
  92.  
  93.       oGet:name := Trim(GetName)
  94.       IF Empty(SayColor)
  95.         SAY_COLOR(oGet, NIL)
  96.       ELSE
  97.         SAY_COLOR(oGet, Trim(SayColor))
  98.       ENDIF
  99.  
  100.       IF Empty(GetFld)
  101.         GET_BLOCK(oGet, NIL)
  102.         GET_VALUE(oGet, NIL)
  103.         oGet:preBlock := {|| .F. }
  104.       ELSE
  105.         GET_BLOCK(oGet, FieldBlock(GetFld))
  106.         GET_VALUE(oGet, Eval(FieldBlock(GetFld)))
  107.         oGet:block   := Oblk(oGet)
  108.         oGet:row     := GetRow
  109.         oGet:col     := GetCol
  110.         oGet:picture := Trim(GetPict)
  111.  
  112.         IF !Empty(GetColor)
  113.           oGet:colorSpec := GetColor
  114.         ENDIF
  115.  
  116.         IF !Empty(GetWhen)
  117.           oGet:preBlock := &GetWhen
  118.         ENDIF
  119.  
  120.         IF !Empty(GetValid)
  121.           oGet:postBlock := &GetValid
  122.         ENDIF
  123.       ENDIF
  124.     ENDIF
  125.     Screens -> (DbSkip(1))
  126.   ENDDO
  127.  
  128. RETURN aGets
  129.  
  130.  
  131. FUNCTION ReadScreen(aScreen)
  132.  
  133. LOCAL i
  134. LOCAL oGet
  135. LOCAL nGets := Len(aScreen)
  136.  
  137.   CLEAR SCREEN
  138.   // DevOutPict is not documented .. Pass 3rd param as color
  139.   FOR i := 1 TO nGets
  140.     oGet := aScreen[i]
  141.     DevPos(SAY_ROW(oGet), SAY_COL(oGet))
  142.     DevOutPict(SAY_STRING(oGet), SAY_PICT(oGet), SAY_COLOR(oGet))
  143.     IF oGet:block != NIL
  144.       oGet:display()
  145.     ENDIF
  146.   NEXT
  147.  
  148.   ReadModal(aScreen)
  149.   IF LastKey() != K_ESC .AND. Updated()
  150.     IF Rlock()
  151.       FOR i := 1 TO nGets
  152.         oGet := aScreen[i]
  153.         IF oGet:block != NIL
  154.           Eval(GET_BLOCK(oGet), GET_VALUE(oGet))
  155.         ENDIF
  156.       NEXT
  157.     ENDIF
  158.   ENDIF
  159.  
  160. RETURN NIL
  161.  
  162.  
  163. FUNCTION Oblk(oGet)
  164.  
  165. RETURN {|x| iif(x == NIL, GET_VALUE(oGet), ;
  166.                           GET_VALUE(oGet, x))}
  167.  
  168.  
  169. FUNCTION GetFldRefresh(aGets)
  170.  
  171.   Aeval(aGets, ;
  172.        {|oGet| iif(oGet:block != NIL,  ;
  173.                    DictPutPair(oGet:cargo, ;
  174.                                {"Get Value", ;
  175.                                 Eval(DictAt(oGet:cargo, "Get Block")) } ), ;
  176.                    NIL) })
  177.  
  178. RETURN NIL
  179.  
  180.  
  181. FUNCTION test(p, l, v)
  182.  
  183.   @ 18, 0
  184.   ? p, l, v
  185.   Inkey(0)
  186.  
  187. RETURN NIL
  188.