home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / WEBER.ZIP / COLOR.PRG < prev    next >
Encoding:
Text File  |  1990-06-01  |  6.0 KB  |  191 lines
  1. #command SAVE GETS => __PushGet()
  2. #command REST GETS => __PopGet()
  3. #define ZipFmt GETLIST[5][5]
  4. #define ZipRow GETLIST[5][1]
  5. #define ZipCol GETLIST[5][2]
  6. #define SCR_COLOR IIF(ISCOLOR(),'GB/N,GB/N','W/N,W/N')
  7. #define S_G_COLOR IIF(ISCOLOR(),'RG+/N,N/W,,,W+/B','W/N,N/W,,,W/N')
  8. #define LBL_COLOR IIF(ISCOLOR(),'W+/G','W/N')
  9. #define MNU_COLOR IIF(ISCOLOR(),'W+/N,RG+/R','W/N,N/W')
  10. #define HDR_COLOR IIF(ISCOLOR(),'N/G','N/W')
  11. #define BGD_COLOR IIF(ISCOLOR(),'R/R,R/R','W/N,W/N')
  12. #define HLP_COLOR IIF(ISCOLOR(),'RG+/B','RG+/B')
  13. #define ALERT_COLOR IIF(ISCOLOR(),'*R+/B','*R+/B')
  14.  
  15. *...............................................
  16. * Simple.prg
  17. *
  18. SET SCOREBOARD OFF
  19. LOCAL Key, choice := 1
  20. USE PGCUS
  21. SET DELETED ON
  22. CLS
  23. SETCOLOR(BGD_COLOR)        && set background
  24. @ 1,0 CLEAR TO 22,79
  25. SETCOLOR(SCR_COLOR)
  26. @ 05,10 CLEAR TO 20,70
  27. @ 05,10 TO 20,70 DOUBLE
  28. @ 07,15 SAY "Name......:"
  29. @ 09,15 SAY "Street....:"
  30. @ 11,15 SAY "City......:"
  31. @ 13,15 SAY "State.....:"
  32. @ 15,15 SAY "Zip.......:"
  33. @ 17,15 SAY "Date/Time.:"
  34. DO WHILE .T.
  35.    SETCOLOR(S_G_COLOR)           && SAY and GET color set
  36.    @ 07,27 SAY CUSNAME
  37.    @ 09,27 SAY CUSADDR1
  38.    @ 11,27 SAY CUSCITY
  39.    @ 13,27 SAY CUSSTATE
  40.    @ 15,27 SAY CUSZIP
  41.    @ 17,27 SAY DTOC(DATE())+SPACE(5)+TIME()
  42.    choice = BarMenu(@choice)
  43.    DO CASE
  44.       CASE choice==1        && if Add
  45.          Add_Cus()
  46.       CASE choice==2        && if Edit
  47.          EditFlds()
  48.       CASE choice==3        && if Delete
  49.          delete
  50.       CASE choice==4        && if Prev
  51.          SKIP -1
  52.       CASE choice==5        && if Next
  53.          Skip
  54.       CASE choice==6        && if Top
  55.          GO TOP
  56.       CASE choice==7        && if Bottom
  57.          GO BOTT
  58.       CASE choice==8        && if Credit
  59.          PopWindow()
  60.       OTHERWISE             && Quit
  61.          EXIT
  62.    ENDCASE
  63. ENDDO
  64. @ 23,0
  65. *....................................................
  66. FUNCTION BarMenu
  67. *....................................................
  68. PARAMETER opt
  69. LOCAL OldColor := SETCOLOR(MNU_COLOR)
  70. SET MESSAGE TO 24
  71. SET WRAP ON
  72. @ 23,0
  73. @ 23,0       PROMPT "Add"    MESSAGE "Add a record"
  74. @ 23,COL()+2 PROMPT "Edit"   MESSAGE "Edit record"
  75. @ 23,COL()+2 PROMPT "Del"    MESSAGE "Delete Record"
  76. @ 23,COL()+2 PROMPT "Prev"   MESSAGE "Go To Previous record"
  77. @ 23,COL()+2 PROMPT "Next"   MESSAGE "Go To Next Record"
  78. @ 23,COL()+2 PROMPT "Top"    MESSAGE "Go To First Record"
  79. @ 23,COL()+2 PROMPT "Bottom" MESSAGE "Go To Last Record"
  80. @ 23,COL()+2 PROMPT "Credit" MESSAGE "View Credit Info"
  81. @ 23,COL()+2 PROMPT "Quit"   MESSAGE "Quit the System"
  82. MENU TO Opt
  83. SETCOLOR(OldColor)
  84. @ 23,0 CLEAR TO 24,79
  85. RETURN (opt)
  86. *....................................................
  87. PROCEDURE Add_Cus
  88. *....................................................
  89. APPEND BLANK
  90. EditFlds()
  91. RETURN
  92. *....................................................
  93. PROCEDURE PopWindow
  94. *....................................................
  95. LOCAL oldwin := SAVESCREEN(11,30,19,65)
  96. LOCAL OldColor := SETCOLOR(HLP_COLOR)
  97. @ 11,30 CLEAR TO 19,65
  98. @ 11,30 TO 19,65 DOUBLE
  99. @ 13,35 SAY "Credit Limit..: "+STR(CUSCRELIM,5)
  100. SETCOLOR(IF(CUSCREAVA<=0,ALERT_COLOR,HLP_COLOR))
  101. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  102. SETCOLOR(HLP_COLOR)
  103. @ 16,35 SAY "Strike a key to return"
  104. INKEY(0)
  105. RESTSCREEN(11,30,19,65,oldwin)
  106. SETCOLOR(OldColor)
  107. RETURN
  108. *....................................................
  109. PROCEDURE EditFlds
  110. *....................................................
  111. LOCAL CUSNAME,CUSADDR1,CUSCITY,CUSSTATE,CUSZIP
  112. LOCAL OldColor := SETCOLOR(S_G_COLOR)
  113. SET KEY -3 TO ChgZip        && F4 runs ChgZip
  114. SET KEY -4 TO EditCred      && F5 runs EditCred
  115.  
  116. M->CUSNAME  := FIELD->CUSNAME
  117. M->CUSADDR1 := FIELD->CUSADDR1
  118. M->CUSCITY  := FIELD->CUSCITY
  119. M->CUSSTATE := FIELD->CUSSTATE
  120. M->CUSZIP   := FIELD->CUSZIP
  121.  
  122. @ 07,27 GET M->CUSNAME VALID NotNan(M->CUSNAME)
  123. @ 09,27 GET M->CUSADDR1 PICTURE "@!"
  124. @ 11,27 GET M->CUSCITY PICTURE "@!"
  125. @ 13,27 GET M->CUSSTATE WHEN !EMPTY(M->CUSCITY) PICTURE "@A!" ;
  126.                         VALID M->CUSSTATE $ "GA|CA|NY|IL"
  127. @ 15,27 GET M->CUSZIP PICTURE ZipPic()
  128. READ
  129.  
  130. FIELD->CUSNAME  := M->CUSNAME
  131. FIELD->CUSADDR1 := M->CUSADDR1
  132. FIELD->CUSCITY  := M->CUSCITY
  133. FIELD->CUSSTATE := M->CUSSTATE
  134. FIELD->CUSZIP   := M->CUSZIP
  135.  
  136. SET KEY -3 TO
  137. SET KEY -4 TO
  138. SETCOLOR(OldColor)
  139. RETURN
  140. *.............................................................
  141. FUNCTION NotNan(Comp)
  142. *.............................................................
  143. LOCAL retval := .T., OldColor := SETCOLOR(ALERT_COLOR)
  144. IF Comp = "Nantucket"
  145.    @ 23,0 SAY "Sorry, we won't sell to those dead beats!"
  146.    ?? chr(7)           && ring the bell
  147.    retval = .F.
  148. ELSE
  149.    SETCOLOR(OldColor)
  150.    @ 23,0
  151. ENDIF
  152. RETURN retval
  153.  
  154. *..............................................................
  155. PROCEDURE ChgZip(Call_Prg, Line_Num, Input_Var)
  156. *..............................................................
  157. IF ZipFmt == "99999"
  158.    ZipFmt := ZipPic("99999-9999")
  159. ELSE
  160.    ZipFmt := ZipPic("99999")
  161. ENDIF
  162. @ ZipRow, ZipCol SAY SPACE(10)
  163. RETURN
  164.  
  165. *..............................................................
  166. FUNCTION ZipPic(NewPic)      && returns current zip or new zip
  167. *                            && if passed
  168. *..............................................................
  169. STATIC ZPict := "99999-9999"
  170. RETURN IF(VALTYPE(NewPic)=="C", (ZPict := NewPic), ZPict)
  171.  
  172. *.............................................................
  173. PROCEDURE EditCred(Call_Prg, Line_Num, Input_Var)
  174. *.............................................................
  175. LOCAL oldwin := SAVESCREEN(11,30,19,65)
  176. LOCAL OldColor := SETCOLOR(HLP_COLOR)
  177. SAVE GETS
  178. @ 11,30 CLEAR TO 19,65
  179. @ 11,30 TO 19,65 DOUBLE
  180. M->CUSCRELIM := FIELD->CUSCRELIM
  181. @ 13,35 SAY "Credit Limit..:" GET M->CUSCRELIM PICT "99999"
  182. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  183. @ 16,35 SAY "Enter New Credit Limit"
  184. READ
  185. FIELD->CUSCREAVA := FIELD->CUSCREAVA+(M->CUSCRELIM-FIELD->CUSCRELIM)
  186. FIELD->CUSCRELIM := M->CUSCRELIM
  187. RESTSCREEN(11,30,19,65,oldwin)
  188. SETCOLOR(OldColor)
  189. REST GETS
  190. RETURN
  191.