home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / xbase / library / dbase / duflp / proc.prg < prev    next >
Text File  |  1992-07-24  |  78KB  |  1,986 lines
  1. *-- PROGRAM.....: PROC.PRG 
  2. *-------------------------------------------------------------------------------
  3. *-- Programmer..: Kenneth J. Mayer, (KENMAYER on BORBBS)
  4. *-- Date........: 06/25/1992
  5. *-- Version.....: 2.6  -- See WHATS.NEW and README.TXT files (both ASCII),
  6. *--               both files uploaded to BORBBS with this file in one
  7. *--               zipped file.
  8. *-- Notes.......: This procedure file is part of the new and improved set of
  9. *--               files, re-designed for dBASE IV, 1.5. The complete set is
  10. *--               contained in the file: LIB16.ZIP. Please read README.TXT
  11. *--               for all instructions.
  12. *===============================================================================
  13.  
  14. *===============================================================================
  15. * MESSAGE/SCREEN PROCESSING ROUTINES -- includes message boxes, shadowing,
  16. * and centering of text ... Anything not here is in the library file: 
  17. * SCREEN.PRG.
  18. *===============================================================================
  19.  
  20. PROCEDURE PrintErr
  21. *-------------------------------------------------------------------------------
  22. *-- Programmer..: Ken Mayer (KENMAYER)
  23. *-- Date........: 05/24/1991
  24. *-- Notes.......: Used to display a printer error for STAND-ALONE
  25. *--               systems. (The dBASE function PRINTSTATUS() doesn't work
  26. *--               well on a Network with Print Spoolers ...)
  27. *-- Written for.: dBASE IV, 1.1
  28. *-- Rev. History: None
  29. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  30. *--               CENTER               Procedure in PROC.PRG
  31. *-- Called by...: Any
  32. *-- Usage.......: do printerr
  33. *-- Example.....: do setprint  && if it hasn't been done
  34. *--               if .not. printstatus()
  35. *--                  DO PRINTERR
  36. *--               endif
  37. *--               *    or
  38. *--               do while .not. printstatus() && my preference ... loop!
  39. *--                  DO PRINTERR
  40. *--               enddo
  41. *-- Returns.....: None
  42. *-- Parameters..: None
  43. *-------------------------------------------------------------------------------
  44.  
  45.     private cColor, cDummy, cCursor
  46.     
  47.     if iscolor()    && if we're using a color monitor, use yellow on red
  48.         cColor = "RG+/R,RG+/R,RG+/R"
  49.     else            && otherwise, use black on white
  50.         cColor = "N/W,N/W,N/W"
  51.     endif
  52.     
  53.     define window wPErr from  7,15 to 16,57 double color &cColor
  54.     save screen to sPErr       && store current screen
  55.     do shadow with 7,15,16,57    && shadow box!
  56.     activate window wPErr      && here we go ..
  57.     
  58.     cCursor=set("CURSOR")      && save cursor setting
  59.     set cursor off             && turn cursor off
  60.                                && display message
  61.     do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
  62.     do center with 2,40,""," The printer is not ready. Please check:"
  63.     do center with 3,40,"","1) that the printer is ON,        "
  64.     do center with 4,40,"","2) that the printer is ONLINE, and"
  65.     do center with 5,40,"","3) that the printer has paper.    "
  66.     do center with 7,40,"","Press any key to continue . . ."
  67.     
  68.     cDummy=inkey(0)            && wait for user to press a key ...
  69.     set cursor &cCursor        && set cursor to original setting ...
  70.     
  71.     deactivate window wPErr    && cleanup
  72.     release window wPErr
  73.     restore screen from sPErr
  74.     release screen sPErr
  75.     
  76. RETURN  
  77. *-- EoP: PrintErr
  78.  
  79. PROCEDURE Open_Screen
  80. *-------------------------------------------------------------------------------
  81. *-- Programmer..: Rick Price (HAMMETT)
  82. *-- Date........: 05/24/1991
  83. *-- Notes.......: Used to give a texture to the background of the screen
  84. *--               I got this from Rick when he uploaded it as part of his 
  85. *--               original entry to a Color Contest on the ATBBS. It is
  86. *--               kinda nice to have that texture on the screen, keeps it
  87. *--               from being monotonous.
  88. *-- Written for.: dBASE IV, 1.1
  89. *-- Rev. History: None
  90. *-- Calls.......: None
  91. *-- Called by...: Any
  92. *-- Usage.......: do open_screen
  93. *-- Example.....: do open_screen
  94. *-- Returns.....: None
  95. *-- Parameters..: None
  96. *-------------------------------------------------------------------------------
  97.  
  98.     private nRow, cBackDrp, nHoldRow
  99.     
  100.     clear
  101.     nRow=0
  102.     cBackdrp = chr(176)  && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
  103.     do while nRow < 3
  104.        @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
  105.        nHoldRow = nRow
  106.        nRow = nRow + 6
  107.        @nRow,0 to nRow+3,79 cBackdrp
  108.        nRow = nRow + 6
  109.        @nRow,0 to nRow+3,79 cBackdrp
  110.        nRow = nRow + 6
  111.        @nRow,0 to nRow+3,79 cBackdrp
  112.        nRow = nHoldRow + 1
  113.     enddo
  114.     @24,0 to 24,79 cBackdrp
  115.  
  116. RETURN
  117. *-- EoP: OpenScreen
  118.  
  119. PROCEDURE JazClear
  120. *-------------------------------------------------------------------------------
  121. *-- Programmer..: Rick Price (HAMMETT)
  122. *-- Date........: 05/24/1991
  123. *-- Notes.......: Used to clear the screen from the middle out --
  124. *--               could be used with OpenScreen, above. I got this
  125. *--               from Rick at the same time I got the other routine above ...
  126. *--               This requires a full screen (0,0 to 23,79 ...)
  127. *-- Written for.: dBASE IV, 1.1
  128. *-- Rev. History: None
  129. *-- Calls.......: None
  130. *-- Called by...: Any
  131. *-- Usage.......: do jazclear
  132. *-- Examples....: do jazclear
  133. *-- Returns.....: None
  134. *-- Parameters..: None
  135. *-------------------------------------------------------------------------------
  136.  
  137.     private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ;
  138.             mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol
  139.     private nColLeft, nColRite, nRowTop, nRowBot
  140.     
  141.     nWinR1 = 0     && row 1
  142.     nWinR2 = 24  && row 2
  143.     nWinC1 = 0   && column 1
  144.     nWinC2 = 79  && column 2
  145.     nStep = 1    && amount to increment by
  146.       * set starting point
  147.     mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
  148.     mnWinC2 = mnWinC1+1
  149.     mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
  150.     mnWinR2 = mnWinR1+1
  151.     
  152.     ** Adjust step offset values: nColOff & nRowOff
  153.     ** Vertical steps: nWinR1-nWinR1
  154.     nTmpAdjR = int((nWinR2 - nWinR1)/2)
  155.     nTmpAdjC = int((nWinC2 - nWinC1)/2)
  156.     
  157.     nAdjRow = ;
  158.     iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
  159.     
  160.     nAdjCol = ;
  161.     iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
  162.     
  163.     ncolleft = nWinC1
  164.     ncolrite = nWinC2
  165.     nRowTop = nWinR1
  166.     nRowBot = nWinR2
  167.     nWinC1 = mnWinC1
  168.     nWinC2 = mnWinC2
  169.     nWinR1 = mnWinR1
  170.     nWinR2 = mnWinR2
  171.     do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
  172.         nWinR1 # nRowTop .or. nWinR2 # nRowBot)
  173.         
  174.         * Adjust coordinates for the clear (moving out from the middle)
  175.         nWinR1 = ;
  176.         nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
  177.         nWinR2 = ;
  178.         nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
  179.         nWinC1 = ;
  180.         nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
  181.         nWinC2 = ;
  182.         nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
  183.         
  184.         * Perform the clear
  185.         @nWinR1,nWinC1 clear to nWinR2,nWinC2
  186.         @nWinR1,nWinC1 to nWinR2,nWinC2
  187.     enddo
  188.     clear
  189.     
  190. RETURN   
  191. *-- EoP: JazClear
  192.  
  193. PROCEDURE Wipe
  194. *-------------------------------------------------------------------------------
  195. *-- Programmer..: Alan D. Frazier (CALLAE)
  196. *-- Date........: 01/10/1992
  197. *-- Notes.......: Used to wipe a window from left to right. Nice effect.
  198. *--               Parameters are the coordinates of the window ...
  199. *-- Written for.: dBASE IV, 1.1
  200. *-- Rev. History: None
  201. *-- Calls.......: None
  202. *-- Called by...: Any
  203. *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  204. *-- Example.....: define window test from 5,10 to 20,70
  205. *--               activate window test
  206. *--                   *-- do stuff in window
  207. *--               do Wipe with 5,10,20,70
  208. *-- Returns.....: None
  209. *-- Parameters..: nULRow = Upper (Left) Row
  210. *--               nULCol = (Upper) Left Column
  211. *--               nBRRow = Bottom (Right) Row
  212. *--               nBRCol = (Bottom) Right Column
  213. *-------------------------------------------------------------------------------
  214.  
  215.     parameter nULRow,nULCol,nBRRow,nBRCol
  216.  
  217.     private nULRow,nULCol,nBRRow,nBRCol,nCurLeft
  218.  
  219.     nCurLeft = 0    && always start at column 0 within the window
  220.     nBRRow  = nBRRow - nULRow - 2
  221.     nBRCol =  nBRCol - nULCol - 2
  222.  
  223.     do while nCurLeft+2 < nBRCol
  224.         @ 0,nCurLeft clear to nBRRow,nCurLeft + 2
  225.         nCurLeft = nCurLeft  + 2
  226.    enddo
  227.  
  228.    @ 0,nBRCol-2 CLEAR TO nBRRow,nBRCol - 1
  229.  
  230. RETURN
  231. *-- EoP: Wipe
  232.  
  233. PROCEDURE Center
  234. *-------------------------------------------------------------------------------
  235. *-- Programmer..: Miriam Liskin
  236. *-- Date........: 05/24/1991
  237. *-- Notes.......: Centers text on the screen with @says
  238. *-- Written for.: dBASE IV, 1.1
  239. *-- Rev. History: This and all other procedures/functions listed in this
  240. *--               file attributed to Miriam Liskin came from "Liskin's
  241. *--               Programming dBASE IV Book". Very good, worth the money.
  242. *-- Calls.......: None
  243. *-- Called by...: Any
  244. *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
  245. *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
  246. *--                  Note that the color field may be blank: ""
  247. *-- Returns.....: None
  248. *-- Parameters..: nLine  = Line or Row for @/Say
  249. *--               nWidth = Width of screen
  250. *--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
  251. *--                           order to use the default colors of window/screen)
  252. *--               cText  = Message to center on screen
  253. *-------------------------------------------------------------------------------
  254.     
  255.     parameters nLine,nWidth,cColor,cText
  256.     private nCol
  257.     
  258.     nCol = (nWidth - len(cText)) /2
  259.     @nLine,nCol say cText color &cColor.
  260.     
  261. RETURN
  262. *-- EoP: Center
  263.  
  264. FUNCTION Surround
  265. *-------------------------------------------------------------------------------
  266. *-- Programmer..: Miriam Liskin
  267. *-- Date........: 05/24/1991
  268. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  269. *--               the screen
  270. *-- Written for.: dBASE IV, 1.1
  271. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  272. *--               from original procedure
  273. *-- Calls.......: None
  274. *-- Called by...: Any
  275. *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
  276. *-- Example.....: cDummy = surround(5,12,"RG+/GB",;
  277. *--                        "Processing ... Do not Touch!")
  278. *-- Returns.....: Nul/""
  279. *-- Parameters..: nLine   = Line to display "surrounded" message at
  280. *--               nColumn = Column for same (X,Y coordinates for @SAY)
  281. *--               cColor  = Color variable/colors
  282. *--               cText   = Text to be displayed inside box
  283. *-------------------------------------------------------------------------------
  284.     
  285.     parameters nLine,nColumn,cColor,cText
  286.     
  287.     cText = " " + trim(cText) + " "             && add spaces around text
  288.     @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
  289.         color &cColor.                           && draw box
  290.     @nLine,nColumn say cText color &cColor.  && disp. text
  291.     
  292. RETURN "" 
  293. *-- EoF: Surround()
  294.  
  295. FUNCTION Message1
  296. *-------------------------------------------------------------------------------
  297. *-- Programmer..: Miriam Liskin
  298. *-- Date........: 05/24/1991
  299. *-- Notes.......: Displays a message, centered at whatever line you give,
  300. *--               pauses until user presses a key.
  301. *-- Written for.: dBASE IV, 1.1
  302. *-- Rev. History: 04/19/1991 Modified by Ken Mayer (KENMAYER) from Miriam's 
  303. *--                procedure to function
  304. *-- Calls.......: CENTER               Procedure in PROC.PRG
  305. *-- Called by...: Any
  306. *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
  307. *-- Example.....: cDummy = Message1(5,12,"RG+/GB","All Done.")
  308. *-- Returns.....: numeric value of key pressed by user (cUser)
  309. *-- Parameters..: nLine  = Line to display message
  310. *--               nWidth = Width of screen
  311. *--               cColor = Colors for display
  312. *--               cText  = Text to be displayed.
  313. *-------------------------------------------------------------------------------
  314.  
  315.     parameters nLine,nWidth,cColor,cText
  316.     private cCursor, cUser
  317.     
  318.     @nLine,0
  319.     cCursor = set("CURSOR")  && store current state of CURSOR
  320.     set cursor off           && turn it off
  321.     do center with nLine,nWidth,cColor,cText
  322.     cUser = inkey(0)
  323.     set cursor &cCursor      && set cursor to original state
  324.     @nLine,0                 && erase line ...
  325.  
  326. RETURN cUser
  327. *-- EoF: Message1()
  328.  
  329. FUNCTION Message2
  330. *-------------------------------------------------------------------------------
  331. *-- Programmer..: Miriam Liskin
  332. *-- Date........: 06/08/1992
  333. *-- Notes.......: Displays a message in a window, pauses for user to 
  334. *--               press key
  335. *-- Written for.: dBASE IV, 1.1
  336. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  337. *--               04/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  338. *--               06/08/1992 - Modified by same, to do EXPLICIT setting of
  339. *--               colors for window used.
  340. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  341. *--               CENTER               Procedure in PROC.PRG
  342. *--               RECOLOR              Procedure in PROC.PRG
  343. *--               COLORBRK()           Function in PROC.PRG
  344. *-- Called by...: Any
  345. *-- Usage.......: message2("<cText>","<cColor>")
  346. *-- Example.....: cDummy = message2("Finished Processing!",;
  347. *--                         "RG+/GB,,RG+/GB")
  348. *-- Returns.....: numeric value of key pressed by user (cUser)
  349. *-- Parameters..: cText  = Text to be displayed in window
  350. *--               cColor = Colors for window
  351. *-------------------------------------------------------------------------------
  352.  
  353.     parameters cText,cColor
  354.     private cCursor, cUser, cCurColor, cCurBox, cTempCol
  355.     
  356.     cCursor = set("CURSOR")
  357.     set cursor off
  358.     save screen to sMessage
  359.     
  360.     *-- save old colors
  361.     cCurColor = set("ATTRIBUTES")
  362.     *-- set new colors
  363.     cTempCol = colorbrk(cColor,1)
  364.     set color of normal to &cTempCol
  365.     cTempCol = colorbrk(cColor,3)
  366.     set color of box    to &cTempCol
  367.     *-- NOW we see what happens ...
  368.     define window wMessage from 10,10 to 14,70 double
  369.     do shadow with 10,10,14,70
  370.     activate window wMessage
  371.     
  372.     do center with 1,60,"",cText
  373.     wait "" to cUser
  374.     
  375.     *-- cleanup
  376.     set cursor &cCursor
  377.     
  378.     *-- remove window ...
  379.     deactivate window wMessage
  380.     release window wMessage
  381.     restore screen from sMessage
  382.     release screen sMessage
  383.  
  384.     *-- restore old colors
  385.     do recolor with cCurColor
  386.  
  387. RETURN cUser
  388. *-- EoF: Message2()
  389.  
  390. FUNCTION Message3
  391. *-------------------------------------------------------------------------------
  392. *-- Programmer..: Miriam Liskin
  393. *-- Date........: 06/08/1992
  394. *-- Notes.......: Displays a message in a window, pauses for user, 
  395. *--               will wrap a long message inside the window.
  396. *-- Written for.: dBASE IV, 1.1
  397. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  398. *--               04/29/1991 - Modified to Ken Mayer (KENMAYER) add shadow
  399. *--               06/08/1992 - Modified to explicitly set the colors ...
  400. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  401. *--               COLORBRK()           Function in PROC.PRG
  402. *--               RECOLOR              Procedure in PROC.PRG
  403. *-- Called by...: Any
  404. *-- Usage.......: Message3("<cText>","<cColor>")
  405. *-- Example.....: cDummy = Message3("This is a long message that will be"+;
  406. *--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
  407. *-- Returns.....: numeric value of key used to exit window (cUser)
  408. *-- Parameters..: cText  = Text to be displayed
  409. *--               cColor = Colors for window
  410. *-------------------------------------------------------------------------------
  411.  
  412.     parameters cText,cColor
  413.     private nLines,cCursor,cUser,nLMargin,nRMargin,cAlignment,lWrap,;
  414.             cCurColor,cTempCol
  415.     
  416.     nLines = int(len(cText) / 38) + 5    && set # of lines for window
  417.     
  418.     cCursor = set("CURSOR")
  419.     set cursor off
  420.     save screen to sMessage
  421.     
  422.     *-- save colors and set new ones
  423.     cCurColor = SET("ATTRIBUTES")
  424.     cTempCol = colorbrk(cColor,1)
  425.     set color of normal to &cTempCol
  426.     cTempCol = colorbrk(cColor,3)
  427.     set color of box to &cTempCol
  428.     *-- define/activate window
  429.     define window wMessage from 8,20 to 8+nLines,60 double
  430.     do shadow with 8,20,8+nLines,60
  431.     activate window wMessage
  432.     
  433.     nLmargin   = _lmargin
  434.     nRmargin   = _rmargin
  435.     cAlignment = _alignment
  436.     lWrap      = _wrap
  437.     
  438.     _lmargin   = 1 
  439.     _rmargin   = 38
  440.     _alignment = "CENTER"
  441.     _wrap      = .t.
  442.     
  443.     ?cText
  444.     ?
  445.     wait "    Press any key to continue . . ." to cUser
  446.     
  447.     _lmargin   = nLmargin
  448.     _rmargin   = nRmargin
  449.     _alignment = cAlignment
  450.     _wrap      = lWrap
  451.     
  452.     set cursor &cCursor
  453.     deactivate window wMessage
  454.     release window wMessage
  455.     restore screen from sMessage
  456.     release screen sMessage
  457.     *-- restore colors
  458.     do ReColor with cCurColor
  459.  
  460. RETURN cUser
  461. *-- EoF: Message3()
  462.  
  463. FUNCTION Message4
  464. *-------------------------------------------------------------------------------
  465. *-- Programmer..: Miriam Liskin
  466. *-- Date........: 06/08/1992
  467. *-- Notes.......: Displays a 2-line message in a predefined window 
  468. *--                 and pauses
  469. *-- Written for.: dBASE IV, 1.1
  470. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (KENMAYER) to a function
  471. *--               04/29/1991 - Modified to Ken Mayer (KENMAYER) add shadow
  472. *--               06/08/1992 -- Modified to explicitly deal with colors
  473. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  474. *--               CENTER               Procedure in PROC.PRG
  475. *--               COLOROF()            Function in PROC.PRG
  476. *--               COLORBRK()           Function in PROC.PRG
  477. *-- Called by...: Any
  478. *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
  479. *-- Example.....: cDummy = message4("Finished processing.","There are ";
  480. *--                        +ltrim(str(reccount()))+" Records in this file.",;
  481. *--                        "rg+/rg,rg+/rg,rg+/rg")
  482. *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
  483. *-- Parameters..: cText1 = First line of message
  484. *--               cText2 = Second line of message
  485. *--               cColor = Colors for window
  486. *-------------------------------------------------------------------------------
  487.  
  488.     parameters cText1,cText2,cColor
  489.     private cCursor,cUser,nLMargin,nRMargin,lWrap,cCurColor,cTempCol
  490.     
  491.     cCursor = set("CURSOR")
  492.     set cursor off
  493.     save screen to sMessage
  494.     
  495.     *-- save old colors
  496.     cCurColor = set("ATTRIBUTES")
  497.     *-- set new colors
  498.     cTempCol = colorbrk(cColor,1)
  499.     set color of normal to &cTempCol
  500.     cTempCol = colorbrk(cColor,3)
  501.     set color of box    to &cTempCol
  502.     
  503.     define window wMonitor from 10,10 to 17,70 double 
  504.     do shadow with 10,10,17,70
  505.     activate window wMonitor
  506.     
  507.     nLmargin = _lmargin
  508.     nRmargin = _rmargin
  509.     lWrap =    _wrap
  510.     _lmargin = 1 
  511.     _rmargin = 58
  512.     _wrap    = .t.
  513.     
  514.     do center with 1,58,"",cText1
  515.     do center with 2,58,"",cText2
  516.     do center with 4,58,"","Press any key to continue . . ."
  517.     wait "" to cUser
  518.  
  519.     _lmargin = nLmargin
  520.     _rmargin = nRmargin
  521.     _wrap    = lWrap
  522.     set cursor &cCursor
  523.     deactivate window wMonitor
  524.     release window wMonitor
  525.     restore screen from sMessage
  526.     release screen sMessage
  527.     *-- reset colors
  528.     do ReColor with cCurColor
  529.     
  530. RETURN cUser
  531. *-- EoF: Message4()
  532.  
  533. PROCEDURE Monitor
  534. *-------------------------------------------------------------------------------
  535. *-- Programmer..: Miriam Liskin
  536. *-- Date........: 06/08/1992
  537. *-- Notes.......: Displays a status message to monitor a long-running 
  538. *--                 operation that operates on multiple records . . . 
  539. *--                 Should be used with MONITOROFF (below) to cleanup.
  540. *-- Written for.: dBASE IV, 1.1
  541. *-- Rev. History: 04/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  542. *--               06/08/1992 - Modified to handle explicit color setting
  543. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  544. *--               CENTER               Procedure in PROC.PRG
  545. *--               COLORBRK()           Function in PROC.PRG
  546. *-- Called by...: Any
  547. *-- Usage.......: do monitor with "<cText>","<cColor>"
  548. *-- Example.....: cMonColor = set("ATTRIBUTES")
  549. *--               do monitor with "Processing REPORT.DBF","rg+/gb,rg+/gb,rg+/gb"
  550. *--               nRec = 0
  551. *--               do while  && (or SCAN)
  552. *--                  && stuff -- process records
  553. *--                  nRec = nRec + 1
  554. *--                  @4,30 display ltrim(str(nRec)) && current record
  555. *--                                                 && in window MONITOR
  556. *--               enddo  && (or endscan)
  557. *--               do MonitorOff  && procedure to clean-up after this one
  558. *--               do ReColor with cMonColor
  559. *-- Returns.....: None
  560. *-- Parameters..: cText  = Text to display
  561. *--               cColor = Colors for window
  562. *-------------------------------------------------------------------------------
  563.  
  564.     parameters cText,cColor
  565.     private cTempCol
  566.     
  567.     *-- set colors
  568.     cTempCol = colorbrk(cColor,1)
  569.     set color of normal to &cTempCol
  570.     cTempCol = colorbrk(cColor,3)
  571.     set color of box to &cTempCol
  572.     
  573.     save screen to sMonitor
  574.     define window wMonitor From 10,10 to 18,70 double 
  575.     do shadow with 10,10,18,70
  576.     activate window wMonitor
  577.     
  578.     do center with 1,60,"",cText
  579.     do center with 2,60,"","Please do not interrupt"
  580.     @4,10 say "Working on record          of " + ltrim(str(reccount(),5))
  581.     
  582. RETURN
  583. *-- EoP: Monitor
  584.  
  585. PROCEDURE MonitorOff
  586. *-------------------------------------------------------------------------------
  587. *-- Programmer..: Ken Mayer (KENMAYER)
  588. *-- Date........: 05/23/1991
  589. *-- Notes.......: Used to deal with ending routines for MONITOR
  590. *--                 procedure above.
  591. *-- Written for.: dBASE IV, 1.1
  592. *-- Rev. History: None
  593. *-- Calls.......: None
  594. *-- Called by...: Routine using MONITOR  Procedure in PROC.PRG
  595. *-- Usage.......: do monitoroff
  596. *-- Example.....: do monitoroff
  597. *-- Returns.....: None
  598. *-- Parameters..: None
  599. *-------------------------------------------------------------------------------
  600.  
  601.     deactivate window wMonitor
  602.     release window wMonitor
  603.     restore screen from sMonitor
  604.     release screen sMonitor
  605.     
  606. RETURN
  607. *-- EoP: MonitorOff
  608.  
  609. FUNCTION ScrnHead
  610. *-------------------------------------------------------------------------------
  611. *-- Programmer..: Miriam Liskin
  612. *-- Date........: 05/23/1991
  613. *-- Notes.......: Displays a heading on the screen in a box 2 
  614. *--               spaces wider than the text, with a custom border (double 
  615. *--               line top, single the rest)
  616. *-- Written for.: dBASE IV, 1.1
  617. *-- Rev. History: 4/29/1991 - Modified by Ken Mayer (KENMAYER) to add shadow
  618. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  619. *-- Called by...: Any
  620. *-- Usage.......: scrnhead("<cColor>","<cText>")
  621. *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report")
  622. *-- Returns.....: nul/""
  623. *-- Parameters..: cColor = Colors to display box/text in
  624. *--               cText  = text to be displayed.
  625. *-------------------------------------------------------------------------------
  626.  
  627.     parameters cColor,cText
  628.     private cTextStart,cText2
  629.     
  630.     cText2 = " "+trim(cText)+" "             && ad spaces to left and right
  631.     cTextstart = (80-len(trim(cText2)))/2
  632.     do shadow with 1,cTextstart-1,3,81-cTextstart
  633.     @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
  634.         color &cColor.                           && display box
  635.     @2, cTextstart say cText2 color &cColor. && display text
  636.  
  637. RETURN ""
  638. *-- EoF: ScrnHead()
  639.  
  640. FUNCTION YesNo
  641. *-------------------------------------------------------------------------------
  642. *-- Programmer..: Miriam Liskin
  643. *-- Date........: 06/08/1992
  644. *-- Notes.......: Asks a yes/no question in a dialog window/box
  645. *-- Written for.: dBASE IV, 1.1
  646. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  647. *--               04/29/1991 - Modified by Ken Mayer add shadow
  648. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  649. *--                            procedures (YES/NO) that were used for returning
  650. *--                            values from Menu
  651. *--                            (suggested by Clinton L. Warren (VBCES))
  652. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  653. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  654. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  655. *--                            as occaisional problems appear otherwise.
  656. *--               06/08/1992 - Modified (Ken Mayer) to deal with explicit
  657. *--                            color processing.
  658. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  659. *--               CENTER               Procedure in PROC.PRG
  660. *--               COLORBRK()           Function in PROC.PRG
  661. *--               RECOLOR              Procedure in PROC.PRG
  662. *-- Called by...: Any
  663. *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
  664. *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
  665. *--                            "This will destroy the data";
  666. *--                             "in this record.";
  667. *--                             "rg+/gb,n/w,rg+/gb")
  668. *--                  delete
  669. *--               else
  670. *--                  skip
  671. *--               endif
  672. *--
  673. *--                 The middle set of colors should be different, as they
  674. *--                 will be the colors of the YES/NO selections ...
  675. *--                 Options may be blank by using nul values ("")
  676. *-- Returns.....: .t./.f. depending on user's choice from menu
  677. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  678. *--               cMess1  =  First line of Message
  679. *--               cMess2  =  Second line of message
  680. *--               cMess3  =  Third line of message
  681. *--               cColor  =  Colors for window/menu/box
  682. *-------------------------------------------------------------------------------
  683.  
  684.     parameter lAnswer,cMess1,cMess2,cMess3,cColor
  685.     private nLMargin,nRMargin,lWrap,cCurColor,cTempCol
  686.     
  687.     *-- save old colors, and set new ones
  688.     cCurColor = set("ATTRIBUTES")
  689.     cTempCol = colorbrk(cColor,1)
  690.     set color of normal to &cTempCol
  691.     set color of message to &cTempCol
  692.     cTempCol = colorbrk(cColor,2)
  693.     set color of highlight to &cTempCol
  694.     cTempCol = colorbrk(cColor,3)
  695.     set color of box to &cTempCol
  696.     
  697.     save screen to sYesno
  698.     define window wYesno from 8,20 to 15,60 double 
  699.     
  700.     define menu mYesno
  701.     *-- remove && from MESSAGE option if using or might be used on Mono system
  702.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  703.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  704.     on selection pad pYes of mYesno deactivate menu
  705.     on selection pad pNo  of mYesno deactivate menu
  706.     
  707.     do shadow with 8,20,15,60
  708.     activate window wYesno
  709.     nLmargin = _lmargin    && store system values
  710.     nRmargin = _rmargin
  711.     lWrap    = _wrap
  712.     _lmargin   = 2            && set local values
  713.     _rmargin   = 38
  714.     _wrap      = .t.
  715.     
  716.     do center with 0,38,"",cMess1        && center the text
  717.     do center with 2,38,"",cMess2
  718.     do center with 3,38,"",cMess3
  719.  
  720.     *-- deal with user pressing 'Y' or 'N' ...
  721.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  722.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  723.     *-- otherwise deal with regular "menu" abilities
  724.     clear typeahead
  725.    if lAnswer
  726.         activate menu mYesno pad pYes
  727.     else
  728.         activate menu mYesno pad pNo
  729.     endif
  730.     
  731.     *-- clear out ON KEY settings ...
  732.    on key label Y
  733.    on key label N
  734.     _lmargin = nLmargin    && reset system values
  735.     _rmargin = nRmargin
  736.     _wrap    = lWrap
  737.     deactivate window wYesno
  738.     release window wYesno
  739.     restore screen from sYesno
  740.     release screen sYesno
  741.     release menu mYesno
  742.     *-- reset colors
  743.     do ReColor with cCurColor
  744.  
  745. RETURN iif(pad()="PYES",.t.,.f.)
  746. *-- EoF: YesNo()
  747.  
  748. FUNCTION YesNo2
  749. *-------------------------------------------------------------------------------
  750. *-- Programmer..: Miriam Liskin
  751. *-- Date........: 06/08/1992
  752. *-- Notes.......: Asks a yes/no question in a dialog window/box
  753. *-- Written for.: dBASE IV, 1.1
  754. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  755. *--               04/29/1991 - Modified by Ken Mayer add shadow
  756. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  757. *--                            procedures (YES/NO) that were used for returning
  758. *--                            values from Menu
  759. *--                            (suggested by Clinton L. Warren (VBCES))
  760. *--               11/15/1991 - Copied YesNo, modified to allow "location" 
  761. *--                            options -- useful for some screens ...
  762. *--               01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
  763. *--                            press 'Y' or 'N' and have them recognized ...
  764. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  765. *--                            as occaisional problems appear otherwise.
  766. *--               06/08/1992 - Modified by same for explicit color sets.
  767. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  768. *--               CENTER               Procedure in PROC.PRG
  769. *--               COLORBRK()           Function in PROC.PRG
  770. *--               RECOLOR              Procedure in PROC.PRG
  771. *-- Called by...: Any
  772. *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",;
  773. *--                                "<cMess1>","<cMess2>","<cMess3>","<cColor>")
  774. *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",;
  775. *--                            "This will destroy the data";
  776. *--                             "in this record.";
  777. *--                             "rg+/gb,n/w,rg+/gb")
  778. *--                  delete
  779. *--               else
  780. *--                  skip
  781. *--               endif
  782. *--
  783. *--                 The middle set of colors should be different, as they
  784. *--                 will be the colors of the YES/NO selections ...
  785. *--                 Options may be blank by using nul values ("")
  786. *-- Returns.....: .t./.f. depending on user's choice from menu
  787. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  788. *--               cWhere  = location on screen:
  789. *--                            "UL" = Upper Left
  790. *--                            "UC" = Upper Center
  791. *--                            "UR" = Upper Right
  792. *--                            "CL" = Center Left
  793. *--                            "CC" = Center Center
  794. *--                            "CR" = Center Right
  795. *--                            "BL" = Bottom Left
  796. *--                            "BC" = Bottom Center
  797. *--                            "BR" = Bottom Right
  798. *--               cMess1  =  First line of Message
  799. *--               cMess2  =  Second line of message (may be nul = "")
  800. *--               cMess3  =  Third line of message  (may be nul = "")
  801. *--               cColor  =  Colors for window/menu/box
  802. *-------------------------------------------------------------------------------
  803.  
  804.     parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor
  805.     private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC,nLMargin,nRMargin,lWrap,;
  806.         cCurColor,cTempCol
  807.         
  808.     cExact = set("EXACT")
  809.     save screen to sYesno
  810.     *-- save old colors, and set new ones
  811.     cCurColor = set("ATTRIBUTES")
  812.     cTempCol = colorbrk(cColor,1)
  813.     set color of normal to &cTempCol
  814.     set color of message to &cTempCol
  815.     cTempCol = colorbrk(cColor,2)
  816.     set color of highlight to &cTempCol
  817.     cTempCol = colorbrk(cColor,3)
  818.     set color of box to &cTempCol
  819.     
  820.     *-- see what the user gave us ...
  821.     if len(trim(cWhere)) > 0
  822.         cW1 = upper(left(cWhere,1))  && first coordinate (vertical)
  823.         cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
  824.     else
  825.         cW1 = "C"
  826.         cW2 = "C"
  827.     endif
  828.     *-- deal with vertical placement
  829.     do case
  830.         case cW1 = "U"
  831.             nULR =  1   && upper left row
  832.             nBRR =  8   && bottom right row
  833.         case cW1 = "C"
  834.             nULR =  8
  835.             nBRR = 15
  836.         case cW1 = "B"
  837.             nULR = 15
  838.             nBRR = 22
  839.     endcase
  840.     *-- deal with horizontal placement
  841.     do case
  842.         case cW2 = "L"
  843.             nULC =  5   && upper left column
  844.             nBRC = 45   && bottom right column
  845.         case cW2 = "R"
  846.             nULC = 35
  847.             nBRC = 75
  848.         case cW2 = "C"
  849.             nULC = 20
  850.             nBRC = 60
  851.     endcase
  852.     
  853.     define window wYesno from nULR,nULC to nBRR,nBRC double 
  854.     
  855.     define menu mYesno
  856.     *-- remove && from MESSAGE option if using or might be used on Mono system
  857.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  858.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  859.     on selection pad pYes of mYesno deactivate menu
  860.     on selection pad pNo  of mYesno deactivate menu
  861.     *-- start displaying it ... shadow, window ...
  862.     do shadow with nULR,nULC,nBRR,nBRC
  863.     activate window wYesno
  864.     *-- store or set some system values
  865.     nLmargin = _lmargin    
  866.     nRmargin = _rmargin
  867.     lWrap    = _wrap
  868.     _lmargin   = 2            && set local values
  869.     _rmargin   = 38
  870.     _wrap      = .t.
  871.     *-- display text
  872.     do center with 0,38,"",cMess1        && center the text
  873.     do center with 2,38,"",cMess2
  874.     do center with 3,38,"",cMess3
  875.     *-- set 'y' or 'n' keys ...
  876.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  877.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  878.     clear typeahead
  879.    if lAnswer
  880.         activate menu mYesno pad pYes
  881.     else
  882.         activate menu mYesno pad pNo
  883.     endif
  884.    
  885.     *-- reset system ...
  886.     on key label Y
  887.    on key label N
  888.     _lmargin = nLmargin
  889.     _rmargin = nRmargin
  890.     _wrap    = lWrap
  891.     deactivate window wYesno
  892.     release window wYesno
  893.     restore screen from sYesno
  894.     release screen sYesno
  895.     release menu mYesno
  896.     set exact &cExact
  897.     do ReColor with cCurColor
  898.     
  899. RETURN iif(pad()="PYES",.t.,.f.)
  900. *-- EoF: YesNo2()
  901.  
  902. FUNCTION ErrorMsg
  903. *-------------------------------------------------------------------------------
  904. *-- Programmer..: Ken Mayer (KENMAYER)
  905. *-- Date........: 06/08/1992
  906. *-- Notes.......: Display an error message in a Window: 
  907. *--                           ** ERROR [#] **
  908. *--
  909. *--                              Message 1
  910. *--                              Message 2
  911. *--                       Press any key to continue ...
  912. *-- Written for.: dBASE IV, 1.1
  913. *-- Rev. History: 06/08/1992 -- Modified for explicit color handing.
  914. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  915. *--               CENTER               Procedure in PROC.PRG
  916. *--               ALLTRIM()            Function in PROC.PRG
  917. *--               COLORBRK()           Function in PROC.PRG
  918. *--               RECOLOR              Function in PROC.PRG
  919. *-- Called by...: Any
  920. *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
  921. *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
  922. *--                   "rg+/r,rg+/r,rg+/r")
  923. *--               where "errornum" is an error number or nul,
  924. *--               message2 and 3 should be 36 characters or less ...
  925. *--               Colors should include foreground/background,;
  926. *--                 foreground/background,foreground/background
  927. *-- Returns.....: numeric value of keystroke user presses (cUser)
  928. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  929. *--               cMess1 = Error message line 1
  930. *--               cMess2 = Error message line 2
  931. *--               cColor = Colors for text/window/border
  932. *-------------------------------------------------------------------------------
  933.     
  934.     parameters cErr,cMess1,cMess2,cColor
  935.     private cCursor,cUser,cCurColor,cTempCol
  936.     
  937.     *-- save old colors
  938.     cCurColor = set("ATTRIBUTES")
  939.     *-- set new colors
  940.     cTempCol = colorbrk(cColor,1)
  941.     set color of normal to &cTempCol
  942.     cTempCol = colorbrk(cColor,3)
  943.     set color of box to &cTempCol
  944.     
  945.     save screen to sErr
  946.     define window wErr from 8,20 to 15,60 double 
  947.     do shadow with 8,20,15,60
  948.     activate window wErr
  949.     
  950.     cCursor = set("CURSOR")
  951.     set cursor off
  952.     if len(trim(cErr)) > 0  && if there's an error number ...
  953.         do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
  954.     else                      && otherwise, don't display errornumber
  955.         do center with 0,38,"","** ERROR **"
  956.     endif
  957.     do center with 2,38,"",cMess1
  958.     do center with 3,38,"",cMess2
  959.     do center with 5,38,"","Press any key to continue ..."
  960.     cUser=inkey(0)
  961.     
  962.     set cursor &cCursor
  963.     deactivate window wErr
  964.     release window wErr
  965.     restore screen from sErr
  966.     release screen sErr
  967.     *-- reset colors
  968.     do ReColor with cCurColor
  969.     
  970. RETURN cUser
  971. *-- EoF: ErrorMsg()
  972.  
  973. PROCEDURE Shadow
  974. *-------------------------------------------------------------------------------
  975. *-- Programmer..: Ashton-Tate
  976. *-- Date........: 01/27/1992
  977. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  978. *--               picklist functions)
  979. *-- Written for.: dBASE IV, 1.1
  980. *-- Rev. History: 05/23/1991 - original procedure.
  981. *--               12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check
  982. *--               for columns exceeding 79, and temporarily change last col.
  983. *--               value (so routine doesn't "blow up").
  984. *--               01/27/1992 -- Modifiedy by Ken Mayer to check for bottom
  985. *--               of screen, based on what Jim did above. No further than 23.
  986. *-- Calls.......: None
  987. *-- Called by...: Too many to list ...
  988. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  989. *-- Example.....: save screen to sMain
  990. *--               define window wError from 5,15 to 15,65 double color;
  991. *--                    rg+/r,rg+/r,rg+/r
  992. *--               do shadow with 5,15,15,65
  993. *--               activate window WError
  994. *--                && perform actions in window
  995. *--               deactivate window WError
  996. *--               release window WError
  997. *--               restore screen from sMain
  998. *--               release screen sMain
  999. *-- Returns.....: None
  1000. *-- Parameters..: nULRow = Upper Left Row position
  1001. *--               nULCol = Upper Left Column position (x,y)
  1002. *--               nBRRow = Bottom Right Row position
  1003. *--               nBRCol = Bottom Right Column position (x2,y2)
  1004. *-------------------------------------------------------------------------------
  1005.  
  1006.     parameters nULRow,nULCol,nBRRow,nBRCOL
  1007.     private nTempRow,nTempCol,nIncRow,nIncCol
  1008.  
  1009.     nTempRow = iif(nBRRow+1>23,23,nBRRow+1)
  1010.     nTempCol = iif(nBRCol+2>79,79,nBRCol+2)
  1011.     nIncRow = 1
  1012.     nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
  1013.     do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
  1014.         nRightCol = nBRCol
  1015.         nBRCol = iif(nBRCol + 2 > 79,77,nBRCol)
  1016.         nBotRow = nBRRow
  1017.         nBRRow = iif(nBRRow + 1 > 23,22,nBRRow)
  1018.         @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
  1019.         nBRCol = nRightCol
  1020.         nBRRow = nBotRow
  1021.         nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
  1022.         nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
  1023.         nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
  1024.     enddo
  1025.     
  1026. RETURN
  1027. *-- EoP: Shadow
  1028.  
  1029. FUNCTION VPick
  1030. *-------------------------------------------------------------------------------
  1031. *-- Programmer...: Keith G. Chuvala (KGC)
  1032. *-- Date.........: 06/08/1992
  1033. *-- Notes........: Keith wanted a multiple choice picklist routine for use
  1034. *--                with a mouse (or other) ... he got the idea for the AT-USER
  1035. *--                system which he was Beta Testing. Here 'tis ...
  1036. *--                 This creates a quick pick-list for multiple-choice, single-
  1037. *--                 character input. The first letter of the selected bar is
  1038. *--                 returned. If <Esc> is pressed, a null string is returned.
  1039. *--                NOTE: If using this with dBASE IV, 1.1, you must supply
  1040. *--                a parameter for each option below.
  1041. *-- Written for..: dBASE IV, 1.5
  1042. *-- Rev. History.: 06/02/1992 -- Keith first gave this to Ken Mayer to use with
  1043. *--                the BORUSER system.
  1044. *--                06/08/1992 -- Modified to allow passing of a color memvar,
  1045. *--                and then to use explicit color definitions based on it.
  1046. *-- Calls........: COLORBRK()          Function in PROC.PRG
  1047. *--                RECOLOR             Procedure in PROC.PRG
  1048. *-- Called by....: Any
  1049. *-- Usage........: ?VPick(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",;
  1050. *--                 <lShadow>,<cColor>)
  1051. *-- Example......: cHow = VPick(12,15,"~BorBBS ID~Lastname",;
  1052. *--                         "How do you want the data sorted?","Choose one",;
  1053. *--                         "rg+/gb,w+/b,rg+/gb")
  1054. *-- Returns......: First letter of bar selected, or null if <Esc>.
  1055. *-- Parameters...: nRow     = is a numeric value for the top row of the popup.
  1056. *--                nCol     = is a numeric value for the left column.
  1057. *--                cOptions = is a string of options with each preceded by
  1058. *--                        '~', e.g. "~Screen~Printer~Text File~Return to Menu"
  1059. *--                cTitle   = is an optional title, used for the popup heading
  1060. *--                cMessage = is an optional message string for when the popup 
  1061. *--                           is activated on the screen.
  1062. *--                lShadow  = is a logical value indicating whether or not a 
  1063. *--                           shadow is to be placed under the popup.
  1064. *--                cColor   = Colors to be used. Should have three parts --
  1065. *--                           <normal/unselected text>,<highlighted text>,
  1066. *--                           <border>, using the format "Foreground/Background"
  1067. *--                           for each. So examine the example above.
  1068. *-------------------------------------------------------------------------------
  1069.     
  1070.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor
  1071.     private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor
  1072.     
  1073.     *-- get number of parameters, and a few setup steps ...
  1074.     if val(right(version(),3)) > 1.1  && if version of dBASE (RunTime) > 1.1
  1075.        nParameters = pcount()
  1076.     else
  1077.         nParameters = 7
  1078.     endif
  1079.    nCount = 0
  1080.    cReturn = ""
  1081.    cOptions = trim(cOptions)
  1082.    cDispMesg = ""
  1083.    *-- if number of parameters greater/equal to 5, we may have a message
  1084.    *-- at the bottom of the screen ...
  1085.    if nParameters >= 5
  1086.       if len(cMessage) > 0
  1087.          cDispMesg = "MESSAGE "+"'"+cMessage+"'"
  1088.       endif
  1089.    endif
  1090.    *-- define the popup
  1091.    define popup pPickList from nRow,nCol &cDispMesg.
  1092.    nMessage1 = 0
  1093.    *-- if we have 4 or more parameters, one of them is the title ...
  1094.    *-- this requires that the first two bars of the menu be skipped ...
  1095.    if nParameters >= 4
  1096.       if len(cTitle) > 0
  1097.          cTitle = " "+cTitle+" "
  1098.          nMessage1 = len(cTitle)
  1099.          nCount = 2
  1100.       endif
  1101.    endif
  1102.  
  1103.     *-- save current colors
  1104.     cCurColor = set("ATTRIBUTES")
  1105.     *-- set new ones
  1106.     cTempCol = colorbrk(cColor,1)
  1107.     set color of normal  to &cTempCol
  1108.     set color of message to &cTempCol
  1109.     cTempCol = colorbrk(cColor,2)
  1110.     set color of highlight to &cTempCol
  1111.     cTempCol = colorbrk(cColor,3)
  1112.     set color of box to &cTempCol
  1113.     
  1114.    *-- now we start parsing the options for the menu. These must have
  1115.    *-- a tilde between each, so we look for the first one, and then
  1116.    *-- look again to see if there's another after that.
  1117.  
  1118.    nPos1 = at("~",cOptions)                        && Look for first tilde
  1119.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop ...
  1120.       if nPos1 > 0
  1121.          cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1122.          nPos2 = at("~",cSub)
  1123.          if nPos2 = 0
  1124.             nPos2 = len(cSub)
  1125.          else
  1126.             nPos2 = nPos2 - 1
  1127.          endif
  1128.          cOptString = " "+left(cSub,nPos2)+" "
  1129.          if len(cOptString) > nMessage1
  1130.             nMessage1 = len(cOptString)
  1131.          endif
  1132.          *-- define the actual 'bar' of the menu/picklist ...
  1133.          nCount = nCount + 1
  1134.          define bar nCount of pPickList prompt cOptString
  1135.          cOptions = cSub
  1136.       endif
  1137.       nPos1 = at("~",cOptions)
  1138.    enddo  && end of parsing loop
  1139.  
  1140.    *-- now we deal with defining the actual picklist ...
  1141.    if nCount > 0             && if we have something to put in the list ...
  1142.       if nParameters >= 4    && if we have a title for the top ...
  1143.          if len(cTitle) > 0
  1144.             if len(cTitle) < nMessage1
  1145.                cTitle = trim(ltrim(cTitle))
  1146.                cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle
  1147.             endif
  1148.             define bar 1 of pPickList prompt cTitle skip
  1149.             define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip
  1150.          endif
  1151.       endif
  1152.       *-- define what to do when a choice is made ...
  1153.       on selection popup pPickList deactivate popup
  1154.       *-- if we have a shadow, let's save screen and do the shadow
  1155.       *-- before popping up the picklist
  1156.         if nParameters => 6
  1157.           if lShadow
  1158.              save screen to sPickScr
  1159.              @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n
  1160.           endif
  1161.         else
  1162.             lShadow = .f.
  1163.         endif
  1164.       *-- there we are ...
  1165.       activate popup pPickList
  1166.  
  1167.       *-- cleanup
  1168.       if lShadow
  1169.         restore screen from sPickScr
  1170.         release screen sPickScr
  1171.       endif
  1172.  
  1173.       *-- deal with what to 'return' ...
  1174.       if lastkey() = 27
  1175.          cReturn = ""
  1176.       else
  1177.          cReturn = substr(prompt(),2,1)
  1178.       endif
  1179.  
  1180.    endif && nCount > 0
  1181.  
  1182.     *-- we're done with it ... return it back to the electronic byte storage
  1183.     *-- bins ... 
  1184.    release popup pPickList
  1185.     do ReColor with cCurColor
  1186.     
  1187. RETURN cReturn
  1188. *-- EoF: VPick()
  1189.  
  1190. FUNCTION HPick
  1191. *-------------------------------------------------------------------------------
  1192. *-- Programmer..: Keith G. Chuvala (KGC)
  1193. *-- Date........: 06/12/1992
  1194. *-- Notes.......: Creates a horizontal pick list for multiple-choice single-
  1195. *--               character input.  The first letter of the selected pad is 
  1196. *--               returned.  If <ESC> is pressed, a null string is returned.
  1197. *-- Written for.: dBASE IV, 1.1, 1.5
  1198. *-- Rev. History: 06/12/1992 -- Ken Mayer (KENMAYER) -- minor changes
  1199. *--               to add explicit color setting ...
  1200. *-- Calls.......: COLORBRK()           Function in PROC.PRG
  1201. *--               RECOLOR              Procedure in PROC.PRG
  1202. *-- Called by...: Any
  1203. *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>";
  1204. *--                     <lShadow>,"<cColor>")
  1205. *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return to Menu",;
  1206. *--                       "Output Options","Select one, or <Esc> to exit",;
  1207. *--                       .t.,"rg+/gb,w+/b,rg+/gb")
  1208. *-- Returns.....: First letter of selected 'pad', or null if <Esc>.
  1209. *-- Parameters..: nRow      = a numeric value for the top row of the popup.
  1210. *--               nCol      = a numeric value for the left column of the popup.
  1211. *--               cOptions  = a string of options with each preceded by '~',
  1212. *--                           e.g. "~Screen~Printer~Text File~Return to Menu"
  1213. *--               cTitle    = an optional title, used for the popup heading
  1214. *--               cMessage  = an optional message string for when the popup 
  1215. *--                           is activated on the screen.
  1216. *--               lShadow   = a logical value indicating whether or not a 
  1217. *--                           shadow is to be placed under the popup.
  1218. *--               cColor    = Colors passed to function in format:
  1219. *--                            <Text/Unselected Pad>,<Selected Pad>,<Border>
  1220. *-------------------------------------------------------------------------------
  1221.  
  1222.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor
  1223.     private cPickColor,cTempCol
  1224.    *-- get number of parameters, and a few setup steps
  1225.     *-- if version 1.5 or later, # of parms is optional ...
  1226.     if val(right(version(),3)) > 1.1  && if version of dBASE > 1.1
  1227.         nParameters = pcount()
  1228.     else
  1229.         nParameters = 7
  1230.     endif
  1231.    nCount = 0
  1232.    nStartCol = nCol
  1233.    cOptions = trim(cOptions)
  1234.    cDispMess = ""
  1235.     *-- save current colors, set up colors for this routine
  1236.     cPickColor = set("ATTRIBUTES")
  1237.     cTempCol = colorbrk(cColor,1)
  1238.     set color of normal to &cTempCol
  1239.     set color of message to &cTempCol
  1240.     cTempCol = colorbrk(cColor,2)
  1241.     set color of highlight to &cTempCol
  1242.     cTempCol = colorbrk(cColor,3)
  1243.     set color of box to &cTempCol
  1244.     
  1245.    cPadName = "p"
  1246.     *-- if # of parameters => 5, we may have a message at the bottom of the
  1247.     *-- screen ...
  1248.    if nParameters >= 5
  1249.       if len(cMessage) > 0
  1250.          cDispMess = "MESSAGE "+"'"+cMessage+"'"
  1251.       endif
  1252.    endif
  1253.     *-- start defining the menu ...
  1254.    define menu mHPick &cDispMess.
  1255.    if nParameters >= 4
  1256.       if len(cTitle) > 0
  1257.          cTitle = " "+cTitle+" "
  1258.       endif
  1259.    endif
  1260.     
  1261.     *-- here, we have to parse the cOptions field for the tilde "~" character,
  1262.     *-- which is how we know we have a new pad ...
  1263.    nPos1 = at("~",cOptions)                        && position of first tilde
  1264.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop
  1265.       if nPos1 = 0 .and. (len(cOptions) > 0)
  1266.          nPos1 = len(cOptions)
  1267.       endif
  1268.       if nPos1 > 0
  1269.          cSubString = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1270.          nPos2 = at("~",cSubString)
  1271.          if nPos2 = 0
  1272.             nPos2 = len(cSubString)
  1273.          else
  1274.             nPos2 = nPos2 - 1
  1275.          endif
  1276.          cOptString = " "+left(cSubString,nPos2)+" "
  1277.          nCount = nCount + 1
  1278.          cPadName = "p"+ltrim(trim(str(nCount)))
  1279.          define pad &cPadName of mHPick prompt cOptString at nRow,nCol
  1280.          nCol = nCol + len(cOptString)
  1281.          on selection pad &cPadName of mHPick deactivate menu
  1282.          cOptions = cSubString
  1283.       endif
  1284.       nPos1 = at("~",cOptions)
  1285.    enddo
  1286.  
  1287.     *-- done figure that out. On to more stuff ...
  1288.    save screen to sPickList
  1289.     *-- do we have a shadow?
  1290.    if lShadow
  1291.       @ nRow,nStartCol+2 fill to nRow+2,nCol+2
  1292.    endif
  1293.     *-- draw border
  1294.    @ nRow-1,nStartCol-1 to nRow+1,nCol
  1295.     *-- display 'title'
  1296.    if len(cTitle) > 0
  1297.       @ nRow-1,nStartCol+1 say cTitle
  1298.    endif
  1299.     *-- start 'er up ...
  1300.    activate menu mHPick
  1301.  
  1302.     *-- that's it ... return screen to it's original
  1303.     *-- state ...
  1304.    restore screen from sPickList
  1305.     release screen sPickList
  1306.     
  1307.     *-- deal with user keystroke/selection ...
  1308.    if lastkey() = 27
  1309.       cReturn = ""
  1310.    else
  1311.       cReturn = substr(prompt(),2,1)
  1312.    endif
  1313.  
  1314.     *-- cleanup.
  1315.    release menu mHPick
  1316.     do ReColor with cPickColor  && reset colors
  1317.  
  1318. RETURN cReturn
  1319. *-- EoF: HPick()
  1320.  
  1321. *===============================================================================
  1322. * COLOR PROCESSING -- These routines handle setting colors, dealing with
  1323. * checking how colors are set, and so on. Anything that's not here is in
  1324. * the library file:  COLOR.PRG.
  1325. *===============================================================================
  1326.  
  1327. PROCEDURE SetColor
  1328. *-------------------------------------------------------------------------------
  1329. *-- Programmer..: Ken Mayer (KENMAYER)
  1330. *-- Date........: 07/24/1992
  1331. *-- Notes.......: This routine is designed set colors of the primary "areas"
  1332. *--               on the screen, based on a color memvar being passed to it.
  1333. *--               This color memvar should contain two sets of colors (normal
  1334. *--               and enhanced). See below for more details. 
  1335. *-- Written for.: dBASE IV, 1.5
  1336. *-- Rev. History: None
  1337. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  1338. *-- Called by...: Any
  1339. *-- Usage.......: do SetColor with <cColorVar>
  1340. *-- Example.....: cOldColor = set("ATTRIBUTES")  && save old colors
  1341. *--               do SetColor with cl_dialog
  1342. *--                 *-- do whatever needs to be done with these colors
  1343. *--               do ReColor with cOldColor      && restore old colors
  1344. *-- Returns.....: None
  1345. *-- Parameters..: cColorVar = Color memvar. This must contain a "normal"
  1346. *--                           color and a "highlight" color in the format:
  1347. *--                           <forg>/<back>,<forg>/<back>
  1348. *--                           i.e., "rg+/gb,w+/b"
  1349. *-------------------------------------------------------------------------------
  1350.  
  1351.     parameters cColorVar
  1352.     private cNormCol,cHighCol
  1353.     
  1354.     cNormCol = colorbrk(cColorVar,1)  && extract "normal" colors
  1355.     cHighCol = colorbrk(cColorVar,2)  && extract "highlight" colors
  1356.     
  1357.     set color of normal    to &cNormCol  && regular screen/text colors
  1358.     set color of messages  to &cNormCol  && messages/menu pads, etc.
  1359.     set color of box       to &cHighCol  && borders
  1360.     set color of fields    to &cHighCol  && data entry fields
  1361.     set color of highlight to &cHighCol  && highlighted items in menus, etc.
  1362.     
  1363. RETURN
  1364. *-- EoP: SetColor
  1365.  
  1366. PROCEDURE ReColor
  1367. *-------------------------------------------------------------------------------
  1368. *-- Programmer..: Jay Parsons (Jparsons)
  1369. *-- Date........: 04/23/1992
  1370. *-- Notes.......: Restores colors to those held in a string of the form
  1371. *--               returned by set("ATTRIBUTE").
  1372. *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
  1373. *-- Rev. History: None
  1374. *-- Calls       : None
  1375. *-- Called by...: Any
  1376. *-- Usage.......: DO ReColor WITH <cColors>
  1377. *-- Example.....: DO Recolor WITH OldColors
  1378. *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
  1379. *-- Side effects: Changes the screen colors.
  1380. *-------------------------------------------------------------------------------
  1381.  
  1382.   parameters cColors
  1383.   private cThis, cNext, nAt, cLeft, nX, cAreas
  1384.   cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  1385.   cLeft = cColors + ", "
  1386.   nX = 0
  1387.   do while nX < 8
  1388.     nX = nX + 1
  1389.     cThis = substr( cAreas, 4 * nX, 4 )
  1390.     if nX = 3
  1391.       nAt = at( "&", cLeft )
  1392.       cNext = left( cLeft, nAt - 2 )
  1393.       cLeft = substr( cLeft, nAt + 3 )
  1394.       SET COLOR TO , , &cNext
  1395.     else
  1396.       nAt = at( ",", cLeft )
  1397.       cNext = left( cLeft, nAt - 1 )
  1398.       cLeft = substr( cLeft, nAt + 1 )
  1399.       SET COLOR OF &cThis TO &cNext
  1400.     endif
  1401.   enddo
  1402.  
  1403. RETURN
  1404. *-- EoP: ReColor
  1405.  
  1406. FUNCTION ColorBrk
  1407. *-------------------------------------------------------------------------------
  1408. *-- Programmer..: Ken Mayer (KENMAYER)
  1409. *-- Date........: 07/22/1992
  1410. *-- Notes.......: This routine is designed to be used with any of my functions
  1411. *--               and procedures that accept a memory variable for color,
  1412. *--               and use a window. It's purpose is to break that color var
  1413. *--               into it's components (depending on which one the user wants)
  1414. *--               and return those components, so that they can then be used
  1415. *--               in SET COLOR OF ... commands.
  1416. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in
  1417. *--                1.1)
  1418. *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings that
  1419. *--               may have only two parts to them (no <border>...), so that if
  1420. *--               the <nField> parm is 2, we get a valid value.
  1421. *-- Calls.......: None
  1422. *-- Called by...: Any
  1423. *-- Usage.......: ColorBrk(<cColorVar>,<nField>)
  1424. *-- Example.....: set color of normal to ColorBrk(cColor,1)
  1425. *-- Returns.....: Either the field you asked for (1 thru 3) or null string ("").
  1426. *-- Parameters..: cColorVar = Color variable to extract data from
  1427. *--                   Assumes the form: <main color>,<highlight>,<border>
  1428. *--                   Where each part uses: <foreground>/<background> format
  1429. *--                    i.e., rg+/gb,w+/b,rg+/gb
  1430. *--               nField    = Field you want to extract
  1431. *-------------------------------------------------------------------------------
  1432.  
  1433.     parameters cColorVar, nField
  1434.     private cReturn, cExtracted
  1435.     
  1436.     do case
  1437.         case nField = 1
  1438.             cReturn = left(cColorVar,at(",",cColorVar)-1)
  1439.         case nField = 2
  1440.             cExtract = substr(cColorVar,at(",",cColorVar)+1)  && everything to 
  1441.                                                               && right of comma
  1442.             if at(",",cExtract) > 0
  1443.                 cReturn = left(cExtract,at(",",cExtract)-1)    && left of second ,
  1444.             else
  1445.                 cReturn = cExtract
  1446.             endif
  1447.         case nField = 3
  1448.             cExtract = substr(cColorVar,at(",",cColorVar)+1)
  1449.             cReturn = substr(cExtract,at(",",cExtract)+1)
  1450.         otherwise
  1451.             cReturn = ""
  1452.     endcase
  1453.  
  1454. RETURN cReturn
  1455. *-- EoF: ColorBrk()
  1456.  
  1457. *===============================================================================
  1458. * STRING Manipulation. Most of these are in the library file:  STRINGS.PRG
  1459. * The ones here are common to a lot of apps and functions, and are here so
  1460. * that the library STRINGS.PRG need not be called.
  1461. *===============================================================================
  1462.  
  1463. FUNCTION AllTrim
  1464. *-------------------------------------------------------------------------------
  1465. *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
  1466. *-- Date........: 5/23/1991
  1467. *-- Notes.......: Complete trims edges of field (left and right)
  1468. *-- Written for.: dBASE IV, 1.1
  1469. *-- Rev. History: None
  1470. *-- Calls.......: None
  1471. *-- Called by...: Any
  1472. *-- Usage.......: alltrim(<cString>)
  1473. *-- Example.....: ? alltrim("  Test String  ") 
  1474. *-- Returns.....: Trimmed string, i.e.:"Test String"
  1475. *-- Parameters..: cString = string to be trimmed
  1476. *-------------------------------------------------------------------------------
  1477.     
  1478.     parameters cString
  1479.     
  1480. RETURN ltrim(rtrim(cString))
  1481. *-- EoF: AllTrim()
  1482.  
  1483. FUNCTION State
  1484. *-------------------------------------------------------------------------------
  1485. *-- Programmer..: David G. Franknbach (FRNKNBCH)
  1486. *-- Date........: 04/22/1992
  1487. *-- Notes.......: Validation of state codes -- used to ensure that a user
  1488. *--               doing data entry will enter the proper codes. Added a few
  1489. *--               US Territory codes as well (Puerto Rico, etc.)
  1490. *-- Written for.: dBASE IV, 1.1
  1491. *-- Rev. History: 12/02/1991
  1492. *--               03/11/1992 -- Modified by Ken Mayer (KENMAYER) to handle
  1493. *--               the extra US Territories, and to ensure that the data is
  1494. *--               at least temporarily in upper case when doing the check ...
  1495. *--               04/22/1992 -- Modified by Jay Parsons (JPARSONS) to shorten
  1496. *--               (simplify) the routine by removing the cSTATE2 memvar.
  1497. *-- Calls.......: None
  1498. *-- Called by...: None
  1499. *-- Usage.......: STATE(<cState>)
  1500. *-- Example.....: @5,10 get cState valid required state(cState);
  1501. *--                     error chr(7)+"This is not a valid state code!"
  1502. *-- Returns.....: Logical (.t. if found, .f. otherwise)
  1503. *-- Parameters..: cState = state code to be checked ....
  1504. *-------------------------------------------------------------------------------
  1505.  
  1506.     parameters cState
  1507.     
  1508.     cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+;
  1509.                  "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+;
  1510.                  "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI|"
  1511.     lOK = upper(cState) $ cStateList
  1512.  
  1513. RETURN lOK
  1514. *-- EoF: State()
  1515.  
  1516. *===============================================================================
  1517. *  DATE HANDLING ROUTINES -- Most of these are now in the library file: 
  1518. *  DATES.PRG (included with this version of PROC). However, a few are below,
  1519. *  as they have become 'standard' routines in many of my systems.
  1520. *===============================================================================
  1521.  
  1522. FUNCTION DateText
  1523. *-------------------------------------------------------------------------------
  1524. *-- Programmer..: Miriam Liskin
  1525. *-- Date........: 05/23/1991
  1526. *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
  1527. *-- Written for.: dBASE IV, 1.1
  1528. *-- Rev. History: None
  1529. *-- Calls.......: None
  1530. *-- Called by...: Any
  1531. *-- Usage.......: DateText(<dDate>) 
  1532. *-- Example.....: ? datetext(date())
  1533. *-- Returns.....: July 1, 1991
  1534. *-- Parameters..: dDate = date to be converted
  1535. *-------------------------------------------------------------------------------
  1536.  
  1537.     parameters dDate
  1538.     
  1539. RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1540. *-- EoF: DateText()
  1541.  
  1542. FUNCTION DateText2
  1543. *-------------------------------------------------------------------------------
  1544. *-- Programmer..: Miriam Liskin
  1545. *-- Date........: 05/23/1991
  1546. *-- Notes.......: Display date in format day-of-week, Month day, year
  1547. *-- Written for.: dBASE IV, 1.1
  1548. *-- Rev. History: None
  1549. *-- Calls.......: None
  1550. *-- Called by...: Any
  1551. *-- Usage.......: DateText2(<dDate>)
  1552. *-- Example.....: ? DateText2(date())
  1553. *-- Returns.....: Thursday, July 1, 1991
  1554. *-- Parameters..: dDate = date to be converted
  1555. *-------------------------------------------------------------------------------
  1556.  
  1557.     parameters dDate
  1558.     
  1559. RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
  1560.        ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  1561. *-- EoF: DateText2()
  1562.  
  1563. FUNCTION Age
  1564. *-------------------------------------------------------------------------------
  1565. *-- Programmer..: Martin Leon (HMAN)
  1566. *-- Date........: 10/23/91
  1567. *-- Notes.......: Returns age of person, given their birthdate as of DATE(),
  1568. *--               effectively, as of "Today".
  1569. *-- Written for.: dBASE IV, 1.1
  1570. *-- Rev. History: None
  1571. *-- Calls.......: None
  1572. *-- Called by...: Any
  1573. *-- Usage.......: Age(<dBDay>)
  1574. *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..."
  1575. *-- Returns.....: Numeric value in years
  1576. *-- Parameters..: dBDay = birthdate of person attempting to find age of.
  1577. *-------------------------------------------------------------------------------
  1578.  
  1579.     parameters dBDay
  1580.     private dToday,nYears
  1581.     
  1582.     dToday = date()
  1583.     nYears = year(dToday) - year(dBDay)
  1584.     do case
  1585.         case month(dBDay) > month(dToday)
  1586.             nYears = nYears - 1
  1587.         case month(dBDay) = month(dToday)
  1588.             if day(dBDay) > day(dToday)
  1589.                 nYears = nYears - 1
  1590.             endif
  1591.     endcase
  1592.  
  1593. RETURN nYears
  1594. *-- EoF: Age()
  1595.  
  1596. *===============================================================================
  1597. * FIELD HANDLING ROUTINES -- Unique searches, string manipulation ...
  1598. * The ones left in PROC.PRG are the more commonly used ones. Anything else is
  1599. * in the library file: FIELDS.PRG.
  1600. *===============================================================================
  1601.  
  1602. FUNCTION IsUnique
  1603. *-------------------------------------------------------------------------------
  1604. *-- Programmer..: Clinton L. Warren (VBCES)
  1605. *-- Date........: 04/28/1992
  1606. *-- Notes.......: Checks to see if an index key already exists in the current
  1607. *--               selected database. This function was inspired by Tom
  1608. *--               Woodward's Chk4Dup UDF.
  1609. *-- Written for.: dBASE IV, 1.1
  1610. *-- Rev. History: May 15, 1991 Version 1.1  Added check for zero record database
  1611. *--               May  7, 1991 Version 1.0  Initial 'release'.
  1612. *--               04/28/1992 -- modified for dBASE IV, 1.5 due to 'new'
  1613. *--               behavior (see READ.ME that comes with 1.5). Should function
  1614. *--               fine with 1.1 and 1.0. This change from David Love (DAVIDLOVE).
  1615. *--               NOTE: NEW PARAMETER
  1616. *-- Calls.......: None
  1617. *-- Called by...: Any
  1618. *-- Usage.......: IsUnique(<xValue>,"<cOrder>","<cField>")
  1619. *-- Example.....: @5,5 SAY "SSN: " GET SSN PICTURE "999-99-9999";
  1620. *--                  valid required IsUnique(SSN, "SSN", "SSN");
  1621. *--                  message "Enter a new SSN";
  1622. *--                  error chr(7)+"SSN must be unique!"
  1623. *-- Returns.....: .T./.F.
  1624. *-- Parameters..: xValue = Value (any non-memo type) to check for uniqueness
  1625. *--               cOrder = MDX Tag used to order the database. Must be set for
  1626. *--                        field being checked.
  1627. *--               cField = field name for 'get'.
  1628. *-------------------------------------------------------------------------------
  1629.     
  1630.     parameters xValue, cOrder, cField
  1631.     private nRecNo, nRecCnt, cSetNear, cSetDel, lIsDeleted, cSetOrder
  1632.     private lIsUnique
  1633.     
  1634.     nRecNo = recno()           && store current record number
  1635.     nRecCnt = reccount()       && count records in database
  1636.     
  1637.     if nRecCnt = 0             && empty database, cValue MUST be unique
  1638.        return .t.
  1639.     endif
  1640.     
  1641.     cSetNear = set('NEAR')     && store status of NEAR flag
  1642.     set near off               && set it off
  1643.     cSetDel = set('DELETE')    && store status of DELETE
  1644.     set delete on              && Delete must be ON for this to work
  1645.     lIsDeleted = deleted()     && is current record deleted?
  1646.     delete                     && set delete flag for current record
  1647.     cSetOrder = order()        && store current MDX tag
  1648.     set order to (cOrder)      && set tag to that sent to function
  1649.     
  1650.     if seek(xValue)            && does it exist already?
  1651.        lIsUnique = .f.         &&   if so, it's not unique
  1652.     else                       && otherwise,
  1653.        lIsUnique = .t.         &&   it is.
  1654.     endif
  1655.    
  1656.    set order to (cSetOrder)   && restore changed settings to original settings
  1657.    set delete &cSetDel
  1658.    set near &cSetNear
  1659.    
  1660.    if nRecNo > nRecCnt        && if called during an append
  1661.       go bottom               && goto the bottom of the database,
  1662.       skip 1                  &&   plus one record (the new one)
  1663.       if lIsUnique            && this is the new part ...
  1664.          replace &cField with xValue
  1665.       endif
  1666.    else
  1667.       go nRecNo               && otherwise, goto the current record number
  1668.    endif
  1669.  
  1670.    if .not. lIsDeleted        && was record 'deleted' before?
  1671.       recall                  && if not, undelete it ... (turn flag off)
  1672.    endif 
  1673.  
  1674. RETURN (lIsUnique)
  1675. *-- EoF: IsUnique()
  1676.  
  1677. *===============================================================================
  1678. * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but
  1679. * are none-the-less very useful ... many of these routines have been placed
  1680. * in the library file:  MISC.PRG.
  1681. *===============================================================================
  1682.  
  1683. PROCEDURE SetPrint
  1684. *-------------------------------------------------------------------------------
  1685. *-- Programmer..: Ken Mayer (KENMAYER)
  1686. *-- Date........: 05/24/1991
  1687. *-- Notes.......: Used to set the the appropriate default settings. 
  1688. *--               (Can be modified easily for other printers ...)
  1689. *--               If you want "letter quality" print on some printers,
  1690. *--               you can take the * out from the one line below. Note
  1691. *--               that some printer drivers don't have a "letter quality" mode,
  1692. *--               and dBASE will spit out an error message if you try to
  1693. *--               force it (by using _pquality). I use this routine for
  1694. *--               various systems, and only use _pquality for my dot matrix
  1695. *--               at home. Change the printer driver below to the one you
  1696. *--               are using. The _pdriver line only REALLY needs to be 
  1697. *--               in use on a LAN, where who knows what settings may have been
  1698. *--               dumped into the printer in between the time you loaded dBASE
  1699. *--               (and the printer driver) and the time you really want to
  1700. *--               print?
  1701. *-- Written for.: dBASE IV, 1.1
  1702. *-- Rev. History: None
  1703. *-- Calls.......: None
  1704. *-- Called by...: Any
  1705. *-- Usage.......: do setprint
  1706. *-- Example.....: do setprint
  1707. *-- Returns.....: None
  1708. *-- Parameters..: None
  1709. *-------------------------------------------------------------------------------
  1710.     *_pdriver  = "HPLAS2I"  && printer driver
  1711.     _ppitch   = "PICA"     && printer pitch (10 CPI)    
  1712.     _box      = .t.          && make sure we can print boxes/line draw
  1713.     _ploffset = 0          && page offset (left side) to 0
  1714.     _lmargin  = 0          && left margin (also set to 0)
  1715.     _rmargin  = 80         && right margin set to 80
  1716.     _plength  = 66         && page length 
  1717.     _peject   = "NONE"     && don't send extra blank pages . . .
  1718.     * _pquality = .t.        && set print quality to high -- not available
  1719.                              && for some printers (i.e., LaserJets)
  1720.     
  1721. RETURN   
  1722. *-- EoP: SetPrint
  1723.  
  1724. FUNCTION DosRun
  1725. *-------------------------------------------------------------------------------
  1726. *-- Programmer..: Michael P. Dean (Ashton-Tate)
  1727. *-- Date........: 05/01/1992
  1728. *-- Notes.......: A routine to run a DOS program, checks to see if a
  1729. *--               window is active -- if so, it avoids the inevitable
  1730. *--               "Press any key to continue" and the subsequent messing
  1731. *--               up of the screen display.
  1732. *-- Written for.: dBASE IV, 1.1
  1733. *-- Rev. History: Pulled from A-T BBS 
  1734. *--               05/13/1991 - modified by Ken Mayer (KENMAYER) to use the DBASE
  1735. *--               RUN() function, rather than the ! or RUN commands.
  1736. *--               (suggested by Clinton L. Warren (VBCES).)
  1737. *--               Minor additions for screens from "Bosephus" on ATBBS 10/31/91
  1738. *--               12/14/1991 - modified by Jim Magnant (TXAGGIE) to deactivate
  1739. *--               and reactivate up to 10 windows ...
  1740. *--               04/21/1992 -- Modified for dBASE IV, 1.5 to use memory 
  1741. *--               handling parameters (.t.,<command>,.t.) of RUN() function.
  1742. *--               05/01/1992 -- Modified to allow use with EITHER 1.1 or 1.5.
  1743. *--                By calling VERSION() without a parm, the version of dBASE
  1744. *--                or RUNTIME is the last three characters on the right. 
  1745. *--                Taking the VAL() of that, we can ask if the version is => 1.5
  1746. *--                and process from there.
  1747. *-- Calls.......: None
  1748. *-- Called by...: Any
  1749. *-- Usage.......: DosRun(<cCmd>)
  1750. *-- Example.....: ndummy = dosrun("DIR /W /P")
  1751. *--                 * or
  1752. *--               ndummy = dosrun(memvar)  && where memvar contains dos
  1753. *--                                        && command and parameters ...
  1754. *-- Returns.....: Nul
  1755. *-- Parameters..: cCmd = Command (and parameters) to be executed
  1756. *-------------------------------------------------------------------------------
  1757.  
  1758.     parameter cCmd
  1759.     private aWindow, n, nRun
  1760.     
  1761.     save screen to sDOS          && save screen ...
  1762.     n = 0                        && set to 0 in case there are NO Windows active
  1763.     declare aWindow[10]
  1764.     aWindow[1] = window()               && grab window name of current window
  1765.     if len(trim(aWindow[1])) > 0        && if there's a window, deactivate
  1766.         n = 1 
  1767.         do while len(trim(aWindow[n])) > 0  && if there are more windows ...
  1768.             deactivate window &aWindow[n]    && deactivate them, too ...
  1769.             n = n + 1
  1770.             aWindow[n] = window()
  1771.         enddo
  1772.     endif
  1773.     set console off                     && don't display to screen
  1774.     if val(right(version(),3)) => 1.5   && check version number. If > 1.5
  1775.         nRun = run(.t.,"&cCmd",.t.)      &&  use complete swapping of dBASE, etc.
  1776.     else                                && else it's 1.1 or 1.0
  1777.         nRun = run("&cCmd")              &&  use older version of RUN() function
  1778.     endif
  1779.     set console on                      && ok, display to screen
  1780.     n = n - 1                           && compensate for final n=n+1 in prev.
  1781.     if len(trim(aWindow[1])) > 1        && if there's a window, reactivate
  1782.        do while n > 0                   && all but last window
  1783.             activate window &aWindow[n]   && activate
  1784.             n = n - 1                     && decrement stack
  1785.         enddo
  1786.         activate window &aWindow[1]      && activate final window ...
  1787.     endif
  1788.     restore screen from sDOS
  1789.     release screen sDOS
  1790.     
  1791. RETURN ""
  1792. *-- EoF: DosRun()
  1793.  
  1794. FUNCTION ScrnRpt
  1795. *-------------------------------------------------------------------------------
  1796. *-- Programmer...: Bryan Flynn (AT/BOR-BBS)
  1797. *-- Date.........: 10/31/91
  1798. *-- Notes........: Used to display a dBASE Report on screen, allowing pauses
  1799. *--                when the screen is full.
  1800. *-- Written for..: dBASE IV, 1.1
  1801. *-- Rev. History.: Changed by a lot of people to current version.
  1802. *-- Calls........: Any
  1803. *-- Called by....: Any
  1804. *-- Usage........: ?ScrnRpt("<cRpt cArg>")
  1805. *-- Example......: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'")
  1806. *-- Returns......: ""  (Nul)
  1807. *-- Parameters...: cRpt  = Name of report with any arguments for command line
  1808. *-------------------------------------------------------------------------------
  1809.  
  1810.     Parameter cRpt
  1811.     private lPWait, nPLength, cEscape
  1812.     
  1813.     *-- save system variables
  1814.    lPWait   = _pwait
  1815.    nPLength = _plength
  1816.     cEscape  = SET("ESCAPE")
  1817.     *-- set new variables
  1818.    _pwait   = .t.
  1819.     _plength = iif("43" $ SET("DISPLAY"),40,25)  && if EGA43, set to 40, else 25
  1820.    set escape on
  1821.     
  1822.     *-- store current screen
  1823.    save screen to sTemp
  1824.    clear
  1825.  
  1826.     *-- set printer to nowhere and generate report
  1827.    set printer to nul
  1828.    report form &cRpt noeject to print
  1829.  
  1830.     *-- set things back to normal
  1831.    set escape &cEscape
  1832.    set printer to LPT1
  1833.    wait
  1834.    clear
  1835.    restore screen from sTemp
  1836.    release screen sTemp
  1837.    _pwait   = lPWait
  1838.    _plength = nPLength
  1839.  
  1840. RETURN ""
  1841. *-- EoF: ScrnRpt()
  1842.  
  1843. FUNCTION IsMouse
  1844. *-------------------------------------------------------------------------------
  1845. *-- Programmer..: Ken Mayer (KENMAYER)
  1846. *-- Date........: 06/18/1992
  1847. *-- Notes.......: This is used to determine the presence of a mouse driver.
  1848. *--               Returns a .t. if a mouse driver is detected, a .f. otherwise.
  1849. *--               This routine will turn the mouse off, automatically. This
  1850. *--               can be used to detect a mouse, and turn it off, as well
  1851. *--               as to set a memvar to determine the current mouse state.
  1852. *--               For example, after running this routine, the mouse will be
  1853. *--               off (if there's a driver).
  1854. *--               ******************************
  1855. *--               **** REQUIRES JPMOUSE.BIN ****
  1856. *--               ******************************
  1857. *-- Written for.: dBASE IV, 1.5
  1858. *-- Rev. History: None
  1859. *-- Calls.......: None
  1860. *-- Called by...: Any
  1861. *-- Usage.......: IsMouse()
  1862. *-- Example.....: ?IsMouse()
  1863. *-- Returns.....: Logical
  1864. *-- Parameters..: None
  1865. *-------------------------------------------------------------------------------
  1866.  
  1867.     private cRetVal, lIsMouse, X
  1868.     
  1869.     Load JPMOUSE.BIN
  1870.     cRetVal = call("JPMOUSE","?")
  1871.     lIsMouse = iif(cRetVal="T",.t.,.f.)
  1872.     if lIsMouse
  1873.         x = call("JPMOUSE","H")
  1874.     endif
  1875.     release module JPMOUSE
  1876.  
  1877. RETURN lIsMouse
  1878. *-- EoF: IsMouse()
  1879.  
  1880. PROCEDURE SetMouse
  1881. *-------------------------------------------------------------------------------
  1882. *-- Programmer..: Ken Mayer (KENMAYER)
  1883. *-- Date........: 06/18/1992
  1884. *-- Notes.......: This is used to determine the presence of a mouse driver,
  1885. *--               and/or turn the mouse cursor off in dBASE IV, 1.5
  1886. *--               ******************************
  1887. *--               **** Requires JPMOUSE.BIN ****
  1888. *--               ******************************
  1889. *-- Written for.: dBASE IV, 1.5
  1890. *-- Rev. History: None
  1891. *-- Calls.......: None
  1892. *-- Called by...: Any
  1893. *-- Usage.......: Do SetMouse with <c_Mouse>
  1894. *-- Example.....: PUBLIC c_Mouse
  1895. *--               x=ismouse()  && function in MISC.PRG
  1896. *--               store "OFF" to c_Mouse  && after calling IsMouse() it's 'Off'
  1897. *--               ON KEY LABEL Alt-M DO SetMouse
  1898. *-- Returns.....: .T.
  1899. *-- Parameters..: c_Mouse = A GLOBAL memory variable -- this can/will be changed
  1900. *--                         by this procedure to the opposite scenario when the
  1901. *--                         routine is called. The concept here is to switch
  1902. *--                         the mouse on and/or off if there's a mouse driver.
  1903. *--                This memvar should be set to the current status of the mouse-
  1904. *--                if on, it should hold "ON" in it ...
  1905. *-------------------------------------------------------------------------------
  1906.  
  1907.     private X
  1908.     
  1909.     if type("C_MOUSE") # "C"         && if c_Mouse has not been defined as
  1910.         return                        &&   a character field, return
  1911.     endif
  1912.     
  1913.     load JPMOUSE.BIN                && load the module
  1914.     
  1915.     *-- if the mouse is off, we're going to set it on ("S"), if on, we're
  1916.     *-- going to set it off "H")
  1917.     cSetMouse = iif(upper(c_Mouse) = "OFF","S","H") 
  1918.     x=call("JPMOUSE",cSetMouse)      
  1919.     
  1920.     release module JPMOUSE           && remove from memory
  1921.     
  1922.     *-- if c_Mouse was 'off' we are setting it 'on', and vice versa
  1923.     c_Mouse = iif(upper(c_Mouse) = "OFF","ON","OFF") && change state of c_Mouse
  1924.  
  1925. RETURN
  1926. *-- EoP: SetMouse
  1927.  
  1928. FUNCTION SwitchLib
  1929. *-------------------------------------------------------------------------------
  1930. *-- Programmer..: Ken Mayer (KENMAYER)
  1931. *-- Date........: 05/01/1992
  1932. *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's designed
  1933. *--               as a quick toggle between libraries. See example below.
  1934. *-- Written for.: dBASE IV, 1.5
  1935. *-- Rev. History: None
  1936. *-- Calls.......: None
  1937. *-- Called by...: Any
  1938. *-- Usage.......: SwitchLib(<cNewLib>)
  1939. *-- Example.....: cOldLib = SwitchLib("FILES")
  1940. *--               *-- execute function/procedure needed
  1941. *--               cOldLib = SwitchLib("&cOldLib")
  1942. *-- Returns.....: Old Library setting
  1943. *-- Parameters..: cNewLib = Library file you wish to change to. If the file
  1944. *--                         extension is not '.PRG', you should add the file
  1945. *--                         extension to the description (I.e, "FILES.LIB")
  1946. *-------------------------------------------------------------------------------
  1947.     
  1948.     parameters cNewLib
  1949.     private cCurLib
  1950.     
  1951.     cCurLib = library()
  1952.     set library to &cNewLib
  1953.     
  1954. RETURN cCurLib
  1955. *-- EoF: SwitchLib()
  1956.  
  1957. FUNCTION VerLevel
  1958. *-------------------------------------------------------------------------------
  1959. *-- Programmer..: Bowen Moursund
  1960. *-- Date........: 06-24-1992
  1961. *-- Notes.......: Returns the numeric version number of the current version
  1962. *--               of dBASE or RUNTIME. Useful in version specific routines.
  1963. *-- Written for.: dBASE IV, 1.5
  1964. *-- Rev. History: None
  1965. *-- Calls.......: None
  1966. *-- Called by...: Any
  1967. *-- Usage.......: VerLevel()
  1968. *-- Example.....: if VerLevel() >= 1.5
  1969. *-- Returns.....: a numeric equivalent of Version()
  1970. *-- Parameters..: None
  1971. *-------------------------------------------------------------------------------
  1972.  
  1973.     private cVersion, nPos
  1974.     cVersion = version()
  1975.     nPos = 1
  1976.     do while left(right(cVersion,nPos),1) # " "
  1977.         nPos = nPos + 1
  1978.     enddo
  1979.  
  1980. RETURN val(right(cVersion,nPos+1))
  1981. *-- Eof() VerLevel
  1982.  
  1983. *===============================================================================
  1984. *-- End of Procedure File -- PROC.PRG
  1985. *===============================================================================
  1986.