home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / WEBER.ZIP / MEMO2.PRG < prev    next >
Encoding:
Text File  |  1990-06-01  |  7.9 KB  |  248 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. SET CONFIRM ON
  20. LOCAL Key, choice := 1
  21. USE PGCUS
  22. SET DELETED ON
  23. CLS
  24. SETCOLOR(BGD_COLOR)        && set background
  25. @ 1,0 CLEAR TO 22,79
  26. ScrTitle("Customer Maintenance Module","CUS")
  27. SETCOLOR(SCR_COLOR)
  28. @ 05,10 CLEAR TO 20,70
  29. @ 05,10 TO 20,70 DOUBLE
  30. @ 07,15 SAY "Name......:"
  31. @ 09,15 SAY "Street....:"
  32. @ 11,15 SAY "City......:"
  33. @ 13,15 SAY "State.....:"
  34. @ 15,15 SAY "Zip.......:"
  35. @ 17,15 SAY "Date/Time.:"
  36. DO WHILE .T.
  37.    SETCOLOR(S_G_COLOR)           && SAY and GET color set
  38.    @ 07,27 SAY CUSNAME
  39.    @ 09,27 SAY CUSADDR1
  40.    @ 11,27 SAY CUSCITY
  41.    @ 13,27 SAY CUSSTATE
  42.    @ 15,27 SAY CUSZIP
  43.    @ 17,27 SAY DTOC(DATE())+SPACE(5)+TIME()
  44.    choice := BarMenu(@choice)
  45.    ModeDisp(choice)
  46.    DO CASE
  47.       CASE choice==1        && if Add
  48.          Add_Cus()
  49.       CASE choice==2        && if Edit
  50.          EditFlds()
  51.       CASE choice==3        && if Delete
  52.          delete
  53.       CASE choice==4        && if Prev
  54.          SKIP -1
  55.       CASE choice==5        && if Next
  56.          Skip
  57.       CASE choice==6        && if Top
  58.          GO TOP
  59.       CASE choice==7        && if Bottom
  60.          GO BOTT
  61.       CASE choice==8        && if Credit
  62.          PopWindow()
  63.       CASE choice==9        && if Remarks
  64.          EditRem()
  65.       OTHERWISE             && Quit
  66.          EXIT
  67.    ENDCASE
  68.    ClrMode()
  69. ENDDO
  70. @ 23,0
  71. *....................................................
  72. PROCEDURE ScrTitle(Title,Lbl)
  73. *....................................................
  74. LOCAL OldColor := SETCOLOR(LBL_COLOR)
  75. @ 1,0 CLEAR TO 1,79
  76. @ 1,INT(40-LEN(Title)/2) SAY Title
  77. @ 1,75 SAY Lbl
  78. SETCOLOR(OldColor)
  79. RETURN
  80. *....................................................
  81. PROCEDURE ModeDisp(Mode)     && Displays Mode
  82. *....................................................
  83. LOCAL OldColor := SETCOLOR(LBL_COLOR), ModeId
  84. LOCAL ModeLst := {"ADD","EDIT","DEL","PREV","NEXT",;
  85.                   "TOP","BOTTOM","CREDIT","REMARKS"}
  86. IF Mode>LEN(ModeLst) .OR. Mode==0
  87.    @ 1,0 SAY "QUIT"
  88. ELSE
  89.    @ 1,0 SAY ModeLst[Mode]
  90. ENDIF
  91. SETCOLOR(OldColor)
  92. RETURN
  93. *....................................................
  94. PROCEDURE ClrMode      && Clears Mode Indicator
  95. *....................................................
  96. LOCAL OldColor := SETCOLOR(LBL_COLOR)
  97. @ 1,0 SAY SPACE(10)
  98. SETCOLOR(OldColor)
  99. RETURN
  100. *....................................................
  101. FUNCTION BarMenu
  102. *....................................................
  103. PARAMETER opt
  104. LOCAL OldColor := SETCOLOR(MNU_COLOR)
  105. SET MESSAGE TO 24
  106. SET WRAP ON
  107. @ 23,0
  108. @ 23,0       PROMPT "Add"     MESSAGE "Add a record"
  109. @ 23,COL()+2 PROMPT "Edit"    MESSAGE "Edit record"
  110. @ 23,COL()+2 PROMPT "Del"     MESSAGE "Delete Record"
  111. @ 23,COL()+2 PROMPT "Prev"    MESSAGE "Go To Previous record"
  112. @ 23,COL()+2 PROMPT "Next"    MESSAGE "Go To Next Record"
  113. @ 23,COL()+2 PROMPT "Top"     MESSAGE "Go To First Record"
  114. @ 23,COL()+2 PROMPT "Bottom"  MESSAGE "Go To Last Record"
  115. @ 23,COL()+2 PROMPT "Credit"  MESSAGE "View Credit Info"
  116. @ 23,COL()+2 PROMPT "Remarks" MESSAGE "Edit Remarks"
  117. @ 23,COL()+2 PROMPT "Quit"    MESSAGE "Quit the System"
  118. MENU TO Opt
  119. SETCOLOR(OldColor)
  120. @ 23,0 CLEAR TO 24,79
  121. RETURN (opt)
  122. *....................................................
  123. PROCEDURE Add_Cus
  124. *....................................................
  125. APPEND BLANK
  126. EditFlds()
  127. RETURN
  128. *....................................................
  129. PROCEDURE PopWindow
  130. *....................................................
  131. LOCAL oldwin := SAVESCREEN(11,30,19,65)
  132. LOCAL OldColor := SETCOLOR(HLP_COLOR)
  133. @ 11,30 CLEAR TO 19,65
  134. @ 11,30 TO 19,65 DOUBLE
  135. @ 13,35 SAY "Credit Limit..: "+STR(CUSCRELIM,5)
  136. SETCOLOR(IF(CUSCREAVA<=0,ALERT_COLOR,HLP_COLOR))
  137. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  138. SETCOLOR(HLP_COLOR)
  139. @ 16,35 SAY "Strike a key to return"
  140. INKEY(0)
  141. RESTSCREEN(11,30,19,65,oldwin)
  142. SETCOLOR(OldColor)
  143. RETURN
  144. *....................................................
  145. PROCEDURE EditFlds
  146. *....................................................
  147. LOCAL CUSNAME,CUSADDR1,CUSCITY,CUSSTATE,CUSZIP
  148. LOCAL OldColor := SETCOLOR(S_G_COLOR)
  149. SET KEY -3 TO ChgZip        && F4 runs ChgZip
  150. SET KEY -4 TO EditCred      && F5 runs EditCred
  151.  
  152. M->CUSNAME  := FIELD->CUSNAME
  153. M->CUSADDR1 := FIELD->CUSADDR1
  154. M->CUSCITY  := FIELD->CUSCITY
  155. M->CUSSTATE := FIELD->CUSSTATE
  156. M->CUSZIP   := FIELD->CUSZIP
  157.  
  158. @ 07,27 GET M->CUSNAME VALID NotNan(M->CUSNAME)
  159. @ 09,27 GET M->CUSADDR1 PICTURE "@!"
  160. @ 11,27 GET M->CUSCITY PICTURE "@!"
  161. @ 13,27 GET M->CUSSTATE WHEN !EMPTY(M->CUSCITY) PICTURE "@A!" ;
  162.                         VALID M->CUSSTATE $ "GA|CA|NY|IL"
  163. @ 15,27 GET M->CUSZIP PICTURE ZipPic()
  164. READ
  165.  
  166. FIELD->CUSNAME  := M->CUSNAME
  167. FIELD->CUSADDR1 := M->CUSADDR1
  168. FIELD->CUSCITY  := M->CUSCITY
  169. FIELD->CUSSTATE := M->CUSSTATE
  170. FIELD->CUSZIP   := M->CUSZIP
  171.  
  172. SET KEY -3 TO
  173. SET KEY -4 TO
  174. SETCOLOR(OldColor)
  175. RETURN
  176. *.............................................................
  177. FUNCTION NotNan(Comp)
  178. *.............................................................
  179. LOCAL retval := .T., OldColor := SETCOLOR(ALERT_COLOR)
  180. IF Comp = "Nantucket"
  181.    @ 23,0 SAY "Sorry, we won't sell to those dead beats!"
  182.    ?? chr(7)           && ring the bell
  183.    retval = .F.
  184. ELSE
  185.    SETCOLOR(OldColor)
  186.    @ 23,0
  187. ENDIF
  188. RETURN retval
  189.  
  190. *..............................................................
  191. PROCEDURE ChgZip(Call_Prg, Line_Num, Input_Var)
  192. *..............................................................
  193. IF ZipFmt == "99999"
  194.    ZipFmt := ZipPic("99999-9999")
  195. ELSE
  196.    ZipFmt := ZipPic("99999")
  197. ENDIF
  198. @ ZipRow, ZipCol SAY SPACE(10)
  199. RETURN
  200.  
  201. *..............................................................
  202. FUNCTION ZipPic(NewPic)      && returns current zip or new zip
  203. *                            && if passed
  204. *..............................................................
  205. STATIC ZPict := "99999-9999"
  206. RETURN IF(VALTYPE(NewPic)=="C", (ZPict := NewPic), ZPict)
  207.  
  208. *.............................................................
  209. PROCEDURE EditCred(Call_Prg, Line_Num, Input_Var)
  210. *.............................................................
  211. LOCAL oldwin := SAVESCREEN(11,30,19,65)
  212. LOCAL OldColor := SETCOLOR(HLP_COLOR)
  213. SAVE GETS
  214. @ 11,30 CLEAR TO 19,65
  215. @ 11,30 TO 19,65 DOUBLE
  216. M->CUSCRELIM := FIELD->CUSCRELIM
  217. @ 13,35 SAY "Credit Limit..:" GET M->CUSCRELIM PICT "99999"
  218. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  219. @ 16,35 SAY "Enter New Credit Limit"
  220. READ
  221. FIELD->CUSCREAVA := FIELD->CUSCREAVA+(M->CUSCRELIM-FIELD->CUSCRELIM)
  222. FIELD->CUSCRELIM := M->CUSCRELIM
  223. RESTSCREEN(11,30,19,65,oldwin)
  224. SETCOLOR(OldColor)
  225. REST GETS
  226. RETURN
  227. *.............................................................
  228. PROCEDURE EditRem        && allows editing of remarks
  229. *.............................................................
  230. LOCAL oldwin := SAVESCREEN(9,5,19,45)
  231. LOCAL OldColor := SETCOLOR(HLP_COLOR)
  232. @ 9,5 CLEAR TO 19,45
  233. @ 9,5 TO 19,45 DOUBLE
  234. @ 19,12 SAY "F10 to Exit, ESC to ABORT"
  235. M->CUSCOMM := FIELD->CUSCOMM
  236. FIELD->CUSCOMM := MEMOEDIT(M->CUSCOMM,10,6,18,44,.T.,"Mem_Key")
  237. RESTSCREEN(9,5,19,45,oldwin)
  238. SETCOLOR(OldColor)
  239. RETURN
  240. *.............................................................
  241. FUNCTION Mem_Key(Status, Line_Num, Col)
  242. *.............................................................
  243. LOCAL retval := 0
  244. IF lastkey() == -9      && F10 pressed
  245.    retval := 23         && return ^W
  246. ENDIF
  247. RETURN retval
  248.