home *** CD-ROM | disk | FTP | other *** search
/ Media Share 9 / MEDIASHARE_09.ISO / progmisc / dblib201.zip / PROC.PRG < prev    next >
Text File  |  1993-03-24  |  119KB  |  2,958 lines
  1. *-- PROGRAM.....: PROC.PRG 
  2. *-------------------------------------------------------------------------------
  3. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  4. *-- Date........: 03/24/1993
  5. *-- Version.....: 2.95 -- See WHATS.NEW and README.TXT files (both ASCII),
  6. *--               both files uploaded 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, 2.0. The complete set is
  10. *--               contained in the file: LIB200.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 (CIS: 71333,1030)
  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: 05/24/1991 -- Original
  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.     activate screen
  54.     define window wPErr from  7,15 to 16,57 double color &cColor
  55.     save screen to sPErr       && store current screen
  56.     do shadow with 7,15,16,57       && shadow box!
  57.     activate window wPErr      && here we go ..
  58.     
  59.     cCursor=set("CURSOR")      && save cursor setting
  60.     set cursor off             && turn cursor off
  61.                    && display message
  62.     do center with 0,40,"",chr(7) + "*** PRINTER ERROR ***"
  63.     do center with 2,40,""," The printer is not ready. Please check:"
  64.     do center with 3,40,"","1) that the printer is ON,        "
  65.     do center with 4,40,"","2) that the printer is ONLINE, and"
  66.     do center with 5,40,"","3) that the printer has paper.    "
  67.     do center with 7,40,"","Press any key to continue . . ."
  68.     
  69.     cDummy=inkey(0)            && wait for user to press a key ...
  70.     set cursor &cCursor        && set cursor to original setting ...
  71.     
  72.     deactivate window wPErr    && cleanup
  73.     release window wPErr
  74.     restore screen from sPErr
  75.     release screen sPErr
  76.     
  77. RETURN  
  78. *-- EoP: PrintErr
  79.  
  80. PROCEDURE Open_Screen
  81. *-------------------------------------------------------------------------------
  82. *-- Programmer..: Rick Price (HAMMETT)
  83. *-- Date........: 05/24/1991
  84. *-- Notes.......: Used to give a texture to the background of the screen
  85. *--               I got this from Rick when he uploaded it as part of his 
  86. *--               original entry to a Color Contest on the ATBBS. It is
  87. *--               kinda nice to have that texture on the screen, keeps it
  88. *--               from being monotonous.
  89. *-- Written for.: dBASE IV, 1.1
  90. *-- Rev. History: 05/24/1991 -- Original
  91. *-- Calls.......: None
  92. *-- Called by...: Any
  93. *-- Usage.......: do open_screen
  94. *-- Example.....: do open_screen
  95. *-- Returns.....: None
  96. *-- Parameters..: None
  97. *-------------------------------------------------------------------------------
  98.  
  99.     private nRow, cBackDrp, nHoldRow
  100.     
  101.     clear
  102.     nRow=0
  103.     cBackdrp = chr(176)  && chr(176) = "░", chr(177) = "▒", chr(178) = "▓"
  104.     do while nRow < 3
  105.        @nRow,0 to nRow+3,79 cBackdrp  && fill this section of the screen
  106.        nHoldRow = nRow
  107.        nRow = nRow + 6
  108.        @nRow,0 to nRow+3,79 cBackdrp
  109.        nRow = nRow + 6
  110.        @nRow,0 to nRow+3,79 cBackdrp
  111.        nRow = nRow + 6
  112.        @nRow,0 to nRow+3,79 cBackdrp
  113.        nRow = nHoldRow + 1
  114.     enddo
  115.     @24,0 to 24,79 cBackdrp
  116.  
  117. RETURN
  118. *-- EoP: OpenScreen
  119.  
  120. PROCEDURE JazClear
  121. *-------------------------------------------------------------------------------
  122. *-- Programmer..: Rick Price (HAMMETT)
  123. *-- Date........: 05/24/1991
  124. *-- Notes.......: Used to clear the screen from the middle out --
  125. *--               could be used with OpenScreen, above. I got this
  126. *--               from Rick at the same time I got the other routine above ...
  127. *--               This requires a full screen (0,0 to 23,79 ...)
  128. *-- Written for.: dBASE IV, 1.1
  129. *-- Rev. History: 05/24/1991 -- Original
  130. *-- Calls.......: None
  131. *-- Called by...: Any
  132. *-- Usage.......: do jazclear
  133. *-- Examples....: do jazclear
  134. *-- Returns.....: None
  135. *-- Parameters..: None
  136. *-------------------------------------------------------------------------------
  137.  
  138.     private nWinR1, nWinR2, nWinC1, nWinC2, nStep, mnWinC1, mnWinC2, ;
  139.         mnWinR1, mnWinR2, nStep, nTmpAdjR, nTmpAdjC, nAdjRow, nAdjCol
  140.     private nColLeft, nColRite, nRowTop, nRowBot
  141.     
  142.     nWinR1 = 0       && row 1
  143.     nWinR2 = 24  && row 2
  144.     nWinC1 = 0   && column 1
  145.     nWinC2 = 79  && column 2
  146.     nStep = 1    && amount to increment by
  147.       * set starting point
  148.     mnWinC1 = int((nWinC2-nWinC1)/2)+nWinC1
  149.     mnWinC2 = mnWinC1+1
  150.     mnWinR1 = int((nWinR2-nWinR1)/2)+nWinR1
  151.     mnWinR2 = mnWinR1+1
  152.     
  153.     ** Adjust step offset values: nColOff & nRowOff
  154.     ** Vertical steps: nWinR1-nWinR1
  155.     nTmpAdjR = int((nWinR2 - nWinR1)/2)
  156.     nTmpAdjC = int((nWinC2 - nWinC1)/2)
  157.     
  158.     nAdjRow = ;
  159.     iif(nTmpAdjC > nTmpAdjR, nTmpAdjR/nTmpAdjC,1) * nStep
  160.     
  161.     nAdjCol = ;
  162.     iif(nTmpAdjR > nTmpAdjC, nTmpAdjC/nTmpAdjR,1) * nStep
  163.     
  164.     ncolleft = nWinC1
  165.     ncolrite = nWinC2
  166.     nRowTop = nWinR1
  167.     nRowBot = nWinR2
  168.     nWinC1 = mnWinC1
  169.     nWinC2 = mnWinC2
  170.     nWinR1 = mnWinR1
  171.     nWinR2 = mnWinR2
  172.     do while (nWinC1#nColLeft .or. nWinC2#nColRite .or. ;
  173.         nWinR1 # nRowTop .or. nWinR2 # nRowBot)
  174.         
  175.         * Adjust coordinates for the clear (moving out from the middle)
  176.         nWinR1 = ;
  177.         nWinR1-iif(nRowTop<nWinR1-nAdjRow,nAdjRow,nWinR1-nRowTop)
  178.         nWinR2 = ;
  179.         nWinR2+iif(nRowBot>nWinR2+nAdjRow,nAdjRow,nRowBot-nWinR2)
  180.         nWinC1 = ;
  181.         nWinC1-iif(nColLeft<nWinC1-nAdjCol,nAdjCol,nWinC1-nColLeft)
  182.         nWinC2 = ;
  183.         nWinC2+iif(nColRite>nWinC2+nAdjCol,nAdjCol,nColRite-nWinC2)
  184.         
  185.         * Perform the clear
  186.         @nWinR1,nWinC1 clear to nWinR2,nWinC2
  187.         @nWinR1,nWinC1 to nWinR2,nWinC2
  188.     enddo
  189.     clear
  190.     
  191. RETURN   
  192. *-- EoP: JazClear
  193.  
  194. PROCEDURE Wipe
  195. *-------------------------------------------------------------------------------
  196. *-- Programmer..: Alan D. Frazier (CALLAE)
  197. *-- Date........: 01/10/1992
  198. *-- Notes.......: Used to wipe a window from left to right. Nice effect.
  199. *--               Parameters are the coordinates of the window ...
  200. *-- Written for.: dBASE IV, 1.1
  201. *-- Rev. History: 01/10/1992 -- Original
  202. *-- Calls.......: None
  203. *-- Called by...: Any
  204. *-- Usage.......: do Wipe with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  205. *-- Example.....: define window test from 5,10 to 20,70
  206. *--               activate window test
  207. *--                   *-- do stuff in window
  208. *--               do Wipe with 5,10,20,70
  209. *-- Returns.....: None
  210. *-- Parameters..: nULRow = Upper (Left) Row
  211. *--               nULCol = (Upper) Left Column
  212. *--               nBRRow = Bottom (Right) Row
  213. *--               nBRCol = (Bottom) Right Column
  214. *-------------------------------------------------------------------------------
  215.  
  216.     parameter nULRow,nULCol,nBRRow,nBRCol
  217.  
  218.     private nULRow,nULCol,nBRRow,nBRCol,nCurLeft
  219.  
  220.     nCurLeft = 0    && always start at column 0 within the window
  221.     nBRRow  = nBRRow - nULRow - 2
  222.     nBRCol =  nBRCol - nULCol - 2
  223.  
  224.     do while nCurLeft+2 < nBRCol
  225.     @ 0,nCurLeft clear to nBRRow,nCurLeft + 2
  226.     nCurLeft = nCurLeft  + 2
  227.    enddo
  228.  
  229.    @ 0,nBRCol-2 CLEAR TO nBRRow,nBRCol - 1
  230.  
  231. RETURN
  232. *-- EoP: Wipe
  233.  
  234. PROCEDURE Center
  235. *-------------------------------------------------------------------------------
  236. *-- Programmer..: Miriam Liskin
  237. *-- Date........: 05/24/1991
  238. *-- Notes.......: Centers text on the screen with @says
  239. *-- Written for.: dBASE IV, 1.1
  240. *-- Rev. History: This and all other procedures/functions listed in this
  241. *--               file attributed to Miriam Liskin came from "Liskin's
  242. *--               Programming dBASE IV Book". Very good, worth the money.
  243. *-- Calls.......: None
  244. *-- Called by...: Any
  245. *-- Usage.......: do center with <nLine>,<nWidth>,"<cColor>","<cText>"
  246. *-- Example.....: do center with 5,65,"RG+/GB","WARNING! This will blow up!"
  247. *--                  Note that the color field may be blank: ""
  248. *-- Returns.....: None
  249. *-- Parameters..: nLine  = Line or Row for @/Say
  250. *--               nWidth = Width of screen
  251. *--               cColor = Colors to be used ("Forg/Back") (may be nul "", in
  252. *--                           order to use the default colors of window/screen)
  253. *--               cText  = Message to center on screen
  254. *-------------------------------------------------------------------------------
  255.     
  256.     parameters nLine,nWidth,cColor,cText
  257.     private nCol
  258.     
  259.     nCol = (nWidth - len(cText)) /2
  260.     @nLine,nCol say cText color &cColor.
  261.     
  262. RETURN
  263. *-- EoP: Center
  264.  
  265. FUNCTION Surround
  266. *-------------------------------------------------------------------------------
  267. *-- Programmer..: Miriam Liskin
  268. *-- Date........: 05/24/1991
  269. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  270. *--               the screen
  271. *-- Written for.: dBASE IV, 1.1
  272. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (CIS: 71333,1030) to a 
  273. *--               function from original procedure
  274. *-- Calls.......: None
  275. *-- Called by...: Any
  276. *-- Usage.......: surround(<nLine>,<nColumn>,"<cColor>","<cText>")
  277. *-- Example.....: cDummy = surround(5,12,"RG+/GB",;
  278. *--                        "Processing ... Do not Touch!")
  279. *-- Returns.....: Nul/""
  280. *-- Parameters..: nLine   = Line to display "surrounded" message at
  281. *--               nColumn = Column for same (X,Y coordinates for @SAY)
  282. *--               cColor  = Color variable/colors
  283. *--               cText   = Text to be displayed inside box
  284. *-------------------------------------------------------------------------------
  285.     
  286.     parameters nLine,nColumn,cColor,cText
  287.     
  288.     cText = " " + trim(cText) + " "          && add spaces around text
  289.     @nLine-1,nColumn-1 to nLine+1,nColumn+len(cText) double;
  290.         color &cColor.                           && draw box
  291.     @nLine,nColumn say cText color &cColor.  && disp. text
  292.     
  293. RETURN "" 
  294. *-- EoF: Surround()
  295.  
  296. FUNCTION Message1
  297. *-------------------------------------------------------------------------------
  298. *-- Programmer..: Miriam Liskin
  299. *-- Date........: 05/24/1991
  300. *-- Notes.......: Displays a message, centered at whatever line you give,
  301. *--               pauses until user presses a key.
  302. *-- Written for.: dBASE IV, 1.1
  303. *-- Rev. History: 04/19/1991 Modified by Ken Mayer from Miriam's 
  304. *--                procedure to function
  305. *-- Calls.......: CENTER               Procedure in PROC.PRG
  306. *-- Called by...: Any
  307. *-- Usage.......: message1(<nLine>,<nWidth>,"<cColor>","<cText>")
  308. *-- Example.....: cDummy = Message1(5,12,"RG+/GB","All Done.")
  309. *-- Returns.....: numeric value of key pressed by user (cUser)
  310. *-- Parameters..: nLine  = Line to display message
  311. *--               nWidth = Width of screen
  312. *--               cColor = Colors for display
  313. *--               cText  = Text to be displayed.
  314. *-------------------------------------------------------------------------------
  315.  
  316.     parameters nLine,nWidth,cColor,cText
  317.     private cCursor, cUser
  318.     
  319.     @nLine,0
  320.     cCursor = set("CURSOR")  && store current state of CURSOR
  321.     set cursor off           && turn it off
  322.     do center with nLine,nWidth,cColor,cText
  323.     cUser = inkey(0)
  324.     set cursor &cCursor      && set cursor to original state
  325.     @nLine,0                 && erase line ...
  326.  
  327. RETURN cUser
  328. *-- EoF: Message1()
  329.  
  330. FUNCTION Message2
  331. *-------------------------------------------------------------------------------
  332. *-- Programmer..: Miriam Liskin
  333. *-- Date........: 06/08/1992
  334. *-- Notes.......: Displays a message in a window, pauses for user to 
  335. *--               press key
  336. *-- Written for.: dBASE IV, 1.1
  337. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  338. *--               04/29/1991 - Modified by Ken Mayer to add shadow
  339. *--               06/08/1992 - Modified by same, to do EXPLICIT setting of
  340. *--               colors for window used.
  341. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  342. *--               CENTER               Procedure in PROC.PRG
  343. *-- Called by...: Any
  344. *-- Usage.......: message2("<cText>","<cColor>")
  345. *-- Example.....: cDummy = message2("Finished Processing!",;
  346. *--                         "RG+/GB,,RG+/GB")
  347. *-- Returns.....: numeric value of key pressed by user (cUser)
  348. *-- Parameters..: cText  = Text to be displayed in window
  349. *--               cColor = Colors for window
  350. *-------------------------------------------------------------------------------
  351.  
  352.     parameters cText,cColor
  353.     private cCursor, cUser
  354.     
  355.     cCursor = set("CURSOR")
  356.     set cursor off
  357.     save screen to sMessage
  358.     
  359.     *-- NOW we see what happens ...
  360.     activate screen
  361.     define window wMessage from 10,10 to 14,70 double color &cColor
  362.     do shadow with 10,10,14,70
  363.     activate window wMessage
  364.     
  365.     do center with 1,60,"",cText
  366.     wait "" to cUser
  367.     
  368.     *-- cleanup
  369.     set cursor &cCursor
  370.     
  371.     *-- remove window ...
  372.     deactivate window wMessage
  373.     release window wMessage
  374.     restore screen from sMessage
  375.     release screen sMessage
  376.  
  377. RETURN cUser
  378. *-- EoF: Message2()
  379.  
  380. FUNCTION Message3
  381. *-------------------------------------------------------------------------------
  382. *-- Programmer..: Miriam Liskin
  383. *-- Date........: 06/08/1992
  384. *-- Notes.......: Displays a message in a window, pauses for user, 
  385. *--               will wrap a long message inside the window.
  386. *-- Written for.: dBASE IV, 1.1
  387. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  388. *--               04/29/1991 - Modified to Ken Mayer add shadow
  389. *--               06/08/1992 - Modified to explicitly set the colors ...
  390. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  391. *-- Called by...: Any
  392. *-- Usage.......: Message3("<cText>","<cColor>")
  393. *-- Example.....: cDummy = Message3("This is a long message that will be"+;
  394. *--                 "wrapped around inside the window.","rg+/gb,,rg+/gb")
  395. *-- Returns.....: numeric value of key used to exit window (cUser)
  396. *-- Parameters..: cText  = Text to be displayed
  397. *--               cColor = Colors for window
  398. *-------------------------------------------------------------------------------
  399.  
  400.     parameters cText,cColor
  401.     private nLines,cCursor,cUser,nLMargin,nRMargin,cAlignment,lWrap
  402.     
  403.     nLines = int(len(cText) / 38) + 5       && set # of lines for window
  404.     
  405.     cCursor = set("CURSOR")
  406.     set cursor off
  407.     save screen to sMessage
  408.     
  409.     *-- define/activate window
  410.     activate screen
  411.     define window wMessage from 8,20 to 8+nLines,60 double color &cColor
  412.     do shadow with 8,20,8+nLines,60
  413.     activate window wMessage
  414.     
  415.     nLmargin   = _lmargin
  416.     nRmargin   = _rmargin
  417.     cAlignment = _alignment
  418.     lWrap      = _wrap
  419.     
  420.     _lmargin   = 1 
  421.     _rmargin   = 38
  422.     _alignment = "CENTER"
  423.     _wrap      = .t.
  424.     
  425.     ?cText
  426.     ?
  427.     wait "    Press any key to continue . . ." to cUser
  428.     
  429.     _lmargin   = nLmargin
  430.     _rmargin   = nRmargin
  431.     _alignment = cAlignment
  432.     _wrap      = lWrap
  433.     
  434.     set cursor &cCursor
  435.     deactivate window wMessage
  436.     release window wMessage
  437.     restore screen from sMessage
  438.     release screen sMessage
  439.  
  440. RETURN cUser
  441. *-- EoF: Message3()
  442.  
  443. FUNCTION Message4
  444. *-------------------------------------------------------------------------------
  445. *-- Programmer..: Miriam Liskin
  446. *-- Date........: 11/09/1992
  447. *-- Notes.......: Displays a 2-line message in a predefined window 
  448. *--                 and pauses
  449. *-- Written for.: dBASE IV, 1.1
  450. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to a function
  451. *--               04/29/1991 - Modified to Ken Mayer add shadow
  452. *--               06/08/1992 -- Modified to explicitly deal with colors
  453. *--               11/09/1992 - Modified by Joey Carroll to deal with text
  454. *--                parameters being too long.
  455. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  456. *--               CENTER               Procedure in PROC.PRG
  457. *-- Called by...: Any
  458. *-- Usage.......: message4("<cText1>","<cText2>","<cColor>")
  459. *-- Example.....: cDummy = message4("Finished processing.","There are ";
  460. *--                        +ltrim(str(reccount()))+" Records in this file.",;
  461. *--                        "rg+/rg,rg+/rg,rg+/rg")
  462. *-- Returns.....: numeric value of key pressed by user to exit window (cUser)
  463. *-- Parameters..: cText1 = First line of message
  464. *--               cText2 = Second line of message
  465. *--               cColor = Colors for window
  466. *-------------------------------------------------------------------------------
  467.  
  468.     parameters cText1,cText2,cColor
  469.     private cCursor,cUser,nLMargin,nRMargin,lWrap
  470.     
  471.     *-- if text params are too long, cut 'em off
  472.     cText1 = left(cText1,58)
  473.     cText2 = left(cText2,58)
  474.     
  475.     cCursor = set("CURSOR")
  476.     set cursor off
  477.     save screen to sMessage
  478.     
  479.     activate screen
  480.     define window wMonitor from 10,10 to 17,70 double color &cColor
  481.     do shadow with 10,10,17,70
  482.     activate window wMonitor
  483.     
  484.     nLmargin = _lmargin
  485.     nRmargin = _rmargin
  486.     lWrap =    _wrap
  487.     _lmargin = 1 
  488.     _rmargin = 58
  489.     _wrap    = .t.
  490.     
  491.     do center with 1,58,"",cText1
  492.     do center with 2,58,"",cText2
  493.     do center with 4,58,"","Press any key to continue . . ."
  494.     wait "" to cUser
  495.  
  496.     _lmargin = nLmargin
  497.     _rmargin = nRmargin
  498.     _wrap    = lWrap
  499.     set cursor &cCursor
  500.     deactivate window wMonitor
  501.     release window wMonitor
  502.     restore screen from sMessage
  503.     release screen sMessage
  504.     
  505. RETURN cUser
  506. *-- EoF: Message4()
  507.  
  508. FUNCTION ScrnHead
  509. *-------------------------------------------------------------------------------
  510. *-- Programmer..: Miriam Liskin
  511. *-- Date........: 05/23/1991
  512. *-- Notes.......: Displays a heading on the screen in a box 2 
  513. *--               spaces wider than the text, with a custom border (double 
  514. *--               line top, single the rest)
  515. *-- Written for.: dBASE IV, 1.1
  516. *-- Rev. History: 4/29/1991 - Modified by Ken Mayer to add shadow
  517. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  518. *-- Called by...: Any
  519. *-- Usage.......: scrnhead("<cColor>","<cText>")
  520. *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report")
  521. *-- Returns.....: nul/""
  522. *-- Parameters..: cColor = Colors to display box/text in
  523. *--               cText  = text to be displayed.
  524. *-------------------------------------------------------------------------------
  525.  
  526.     parameters cColor,cText
  527.     private cTextStart,cText2
  528.     
  529.     cText2 = " "+trim(cText)+" "             && ad spaces to left and right
  530.     cTextstart = (80-len(trim(cText2)))/2
  531.     activate screen
  532.     do shadow with 1,cTextstart-1,3,81-cTextstart
  533.     @1,cTextstart-1 to 3,81-cTextstart 205,196,179,179,213,184,192,217;
  534.         color &cColor.                         && display box
  535.     @2, cTextstart say cText2 color &cColor. && display text
  536.  
  537. RETURN ""
  538. *-- EoF: ScrnHead()
  539.  
  540. FUNCTION YesNo
  541. *-------------------------------------------------------------------------------
  542. *-- Programmer..: Miriam Liskin
  543. *-- Date........: 06/08/1992
  544. *-- Notes.......: Asks a yes/no question in a dialog window/box
  545. *-- Written for.: dBASE IV, 1.1
  546. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  547. *--               04/29/1991 - Modified by Ken Mayer add shadow
  548. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  549. *--                            procedures (YES/NO) that were used for returning
  550. *--                            values from Menu
  551. *--                            (suggested by Clinton L. Warren (VBCES))
  552. *--               01/20/1992 - Modified by Martin Leon (HMan) to handle user
  553. *--                            pressing 'Y' or 'N' keys (with ON KEY ...).
  554. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  555. *--                            as occaisional problems appear otherwise.
  556. *--               06/08/1992 - Modified (Ken Mayer) to deal with explicit
  557. *--                            color processing.
  558. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  559. *--               CENTER               Procedure in PROC.PRG
  560. *-- Called by...: Any
  561. *-- Usage.......: yesno(<lAnswer>,"<cMess1>","<cMess2>","<cMess3>","<cColor>")
  562. *-- Example.....: if YesNo(.t.,"Do You Really Wish To Delete?",;
  563. *--                            "This will destroy the data";
  564. *--                             "in this record.";
  565. *--                             "rg+/gb,n/w,rg+/gb")
  566. *--                  delete
  567. *--               else
  568. *--                  skip
  569. *--               endif
  570. *--
  571. *--                 The middle set of colors should be different, as they
  572. *--                 will be the colors of the YES/NO selections ...
  573. *--                 Options may be blank by using nul values ("")
  574. *-- Returns.....: .t./.f. depending on user's choice from menu
  575. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  576. *--               cMess1  =  First line of Message
  577. *--               cMess2  =  Second line of message
  578. *--               cMess3  =  Third line of message
  579. *--               cColor  =  Colors for window/menu/box
  580. *-------------------------------------------------------------------------------
  581.  
  582.     parameter lAnswer,cMess1,cMess2,cMess3,cColor
  583.     
  584.     save screen to sYesno
  585.     activate screen
  586.     define window wYesno from 8,20 to 15,60 double color &cColor
  587.     
  588.     define menu mYesno
  589.     *-- remove && from MESSAGE option if using or might be used on Mono system
  590.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  591.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  592.     on selection pad pYes of mYesno deactivate menu
  593.     on selection pad pNo  of mYesno deactivate menu
  594.     
  595.     do shadow with 8,20,15,60
  596.     activate window wYesno
  597.     
  598.     do center with 0,38,"",cMess1           && center the text
  599.     do center with 2,38,"",cMess2
  600.     do center with 3,38,"",cMess3
  601.  
  602.     *-- deal with user pressing 'Y' or 'N' ...
  603.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  604.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  605.     *-- otherwise deal with regular "menu" abilities
  606.     clear typeahead
  607.    if lAnswer
  608.         activate menu mYesno pad pYes
  609.     else
  610.         activate menu mYesno pad pNo
  611.     endif
  612.     
  613.     *-- clear out ON KEY settings ...
  614.    on key label Y
  615.    on key label N
  616.     deactivate window wYesno
  617.     release window wYesno
  618.     restore screen from sYesno
  619.     release screen sYesno
  620.     release menu mYesno
  621.  
  622. RETURN iif(pad()="PYES",.t.,.f.)
  623. *-- EoF: YesNo()
  624.  
  625. FUNCTION YesNo2
  626. *-------------------------------------------------------------------------------
  627. *-- Programmer..: Miriam Liskin
  628. *-- Date........: 06/08/1992
  629. *-- Notes.......: Asks a yes/no question in a dialog window/box
  630. *-- Written for.: dBASE IV, 1.1
  631. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  632. *--               04/29/1991 - Modified by Ken Mayer add shadow
  633. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  634. *--                            procedures (YES/NO) that were used for returning
  635. *--                            values from Menu
  636. *--                            (suggested by Clinton L. Warren (VBCES))
  637. *--               11/15/1991 - Copied YesNo, modified to allow "location" 
  638. *--                            options -- useful for some screens ...
  639. *--               01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
  640. *--                            press 'Y' or 'N' and have them recognized ...
  641. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  642. *--                            as occaisional problems appear otherwise.
  643. *--               06/08/1992 - Modified by same for explicit color sets.
  644. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  645. *--               CENTER               Procedure in PROC.PRG
  646. *-- Called by...: Any
  647. *-- Usage.......: yesno2(<lAnswer>,"<cWhere>",;
  648. *--                                "<cMess1>","<cMess2>","<cMess3>","<cColor>")
  649. *-- Example.....: if YesNo2(.t.,"UL","Do You Really Wish To Delete?",;
  650. *--                            "This will destroy the data";
  651. *--                             "in this record.";
  652. *--                             "rg+/gb,n/w,rg+/gb")
  653. *--                  delete
  654. *--               else
  655. *--                  skip
  656. *--               endif
  657. *--
  658. *--                 The middle set of colors should be different, as they
  659. *--                 will be the colors of the YES/NO selections ...
  660. *--                 Options may be blank by using nul values ("")
  661. *-- Returns.....: .t./.f. depending on user's choice from menu
  662. *-- Parameters..: lAnswer = default value (Yes or No) for menu
  663. *--               cWhere  = location on screen:
  664. *--                            "UL" = Upper Left
  665. *--                            "UC" = Upper Center
  666. *--                            "UR" = Upper Right
  667. *--                            "CL" = Center Left
  668. *--                            "CC" = Center Center
  669. *--                            "CR" = Center Right
  670. *--                            "BL" = Bottom Left
  671. *--                            "BC" = Bottom Center
  672. *--                            "BR" = Bottom Right
  673. *--               cMess1  =  First line of Message
  674. *--               cMess2  =  Second line of message (may be nul = "")
  675. *--               cMess3  =  Third line of message  (may be nul = "")
  676. *--               cColor  =  Colors for window/menu/box
  677. *-------------------------------------------------------------------------------
  678.  
  679.     parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor
  680.     private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC
  681.         
  682.     cExact = set("EXACT")
  683.     save screen to sYesno
  684.     
  685.     *-- see what the user gave us ...
  686.     if len(trim(cWhere)) > 0
  687.         cW1 = upper(left(cWhere,1))  && first coordinate (vertical)
  688.         cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
  689.     else
  690.         cW1 = "C"
  691.         cW2 = "C"
  692.     endif
  693.     *-- deal with vertical placement
  694.     do case
  695.         case cW1 = "U"
  696.             nULR =  1   && upper left row
  697.             nBRR =  8   && bottom right row
  698.         case cW1 = "C"
  699.             nULR =  8
  700.             nBRR = 15
  701.         case cW1 = "B"
  702.             nULR = 15
  703.             nBRR = 22
  704.     endcase
  705.     *-- deal with horizontal placement
  706.     do case
  707.         case cW2 = "L"
  708.             nULC =  5   && upper left column
  709.             nBRC = 45   && bottom right column
  710.         case cW2 = "R"
  711.             nULC = 35
  712.             nBRC = 75
  713.         case cW2 = "C"
  714.             nULC = 20
  715.             nBRC = 60
  716.     endcase
  717.     
  718.     activate screen
  719.     define window wYesno from nULR,nULC to nBRR,nBRC double color &cColor
  720.     
  721.     define menu mYesno
  722.     *-- remove && from MESSAGE option if using or might be used on Mono system
  723.     define pad pYes of mYesno Prompt "[Yes]" at 5,10 && message "Yes"
  724.     define pad pNo  of mYesno Prompt "[No]"  at 5,25 && message "No"
  725.     on selection pad pYes of mYesno deactivate menu
  726.     on selection pad pNo  of mYesno deactivate menu
  727.     *-- start displaying it ... shadow, window ...
  728.     do shadow with nULR,nULC,nBRR,nBRC
  729.     activate window wYesno
  730.     
  731.     *-- display text
  732.     do center with 0,38,"",cMess1           && center the text
  733.     do center with 2,38,"",cMess2
  734.     do center with 3,38,"",cMess3
  735.     *-- set 'y' or 'n' keys ...
  736.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  737.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  738.     clear typeahead
  739.    if lAnswer
  740.         activate menu mYesno pad pYes
  741.     else
  742.         activate menu mYesno pad pNo
  743.     endif
  744.    
  745.     *-- reset system ...
  746.     on key label Y
  747.    on key label N
  748.     deactivate window wYesno
  749.     release window wYesno
  750.     restore screen from sYesno
  751.     release screen sYesno
  752.     release menu mYesno
  753.     set exact &cExact
  754.     
  755. RETURN iif(pad()="PYES",.t.,.f.)
  756. *-- EoF: YesNo2()
  757.  
  758. FUNCTION ErrorMsg
  759. *-------------------------------------------------------------------------------
  760. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  761. *-- Date........: 06/08/1992
  762. *-- Notes.......: Display an error message in a Window: 
  763. *--                           ** ERROR [#] **
  764. *--
  765. *--                              Message 1
  766. *--                              Message 2
  767. *--                       Press any key to continue ...
  768. *-- Written for.: dBASE IV, 1.1
  769. *-- Rev. History: 06/08/1992 -- Modified for explicit color handing.
  770. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  771. *--               CENTER               Procedure in PROC.PRG
  772. *--               ALLTRIM()            Function in PROC.PRG
  773. *-- Called by...: Any
  774. *-- Usage.......: ErrorMsg("<cErr>","<cMess1>","<cMess2>","<cColor>")
  775. *-- Example.....: lc_Dummy = errormsg("3","This record","already exists!",;
  776. *--                   "rg+/r,rg+/r,rg+/r")
  777. *--               where "errornum" is an error number or nul,
  778. *--               message2 and 3 should be 36 characters or less ...
  779. *--               Colors should include foreground/background,;
  780. *--                 foreground/background,foreground/background
  781. *-- Returns.....: numeric value of keystroke user presses (cUser)
  782. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  783. *--               cMess1 = Error message line 1
  784. *--               cMess2 = Error message line 2
  785. *--               cColor = Colors for text/window/border
  786. *-------------------------------------------------------------------------------
  787.     
  788.     parameters cErr,cMess1,cMess2,cColor
  789.     private cCursor,cUser,cCurColor,cTempCol
  790.     
  791.     save screen to sErr
  792.     activate screen
  793.     define window wErr from 8,20 to 15,60 double color &cColor
  794.     do shadow with 8,20,15,60
  795.     activate window wErr
  796.     
  797.     cCursor = set("CURSOR")
  798.     set cursor off
  799.     if len(trim(cErr)) > 0  && if there's an error number ...
  800.         do center with 0,38,"","** ERROR "+alltrim(cErr)+" **"
  801.     else                      && otherwise, don't display errornumber
  802.         do center with 0,38,"","** ERROR **"
  803.     endif
  804.     do center with 2,38,"",cMess1
  805.     do center with 3,38,"",cMess2
  806.     do center with 5,38,"","Press any key to continue ..."
  807.     cUser=inkey(0)
  808.     
  809.     set cursor &cCursor
  810.     deactivate window wErr
  811.     release window wErr
  812.     restore screen from sErr
  813.     release screen sErr
  814.     
  815. RETURN cUser
  816. *-- EoF: ErrorMsg()
  817.  
  818. PROCEDURE ProgBar
  819. *-------------------------------------------------------------------------------
  820. *-- Programmer..: Joey D. Carroll (JOEY)
  821. *-- Date........: 10/26/1992
  822. *-- Notes.......: A visual indicator of program activity, i.e. shows
  823. *--               user program didn't die during long processes which
  824. *--               do not normally show 'on screen'.  Serves same purpose
  825. *--               as MONITOR, but is more graphic.
  826. *--               For best appearance, set cursor 'off' from calling
  827. *--               program, outside of the loop which calls PROGBAR.
  828. *-- Written for.: dBASE IV, 1.5
  829. *-- Rev. History: 06/28/1992 -- Original
  830. *--               10/26/1992 - Fixed bug(feature) so that cMessage prints the 
  831. *--                 color requested by cWindCol. Protected existing active 
  832. *--                 Window. (Joey Carroll)
  833. *-- Calls.......: None
  834. *-- Called by...: Any
  835. *-- Usage.......: do PROGBAR with <nQuan>,<cWindCol>,<cFillCol1>,cFillCol2>, ;
  836. *--                   <cMessage>,<nWindWidth>
  837. *-- Example.....: *-- determine what process will be monitored and what the
  838. *--               *-- final value will be, e.g. nReccount = reccount()
  839. *--               use <anyfile>
  840. *--               nReccount = reccount()
  841. *--               set cursor off
  842. *--               scan
  843. *--                  do progbar with nReccount,",,w+/n","w+/r","w+/g", ;
  844. *--                     "Processing records.  Be patient.",40
  845. *--                  *-- do some needed process here
  846. *--               endscan
  847. *--               *-- cleanup
  848. *-- Returns.....: None
  849. *-- Parameters..: nQuan     = maximum number of iterations
  850. *--               cWindCol  = the window colors
  851. *--               cFillCol1 = color of ruler before process
  852. *--               cFillCol2 = color of ruler after process
  853. *--               cMessage  = message displayed to user, may be "".
  854. *--               nWindWid  = (optional) desired width of ruler window.  If
  855. *--                               not specified, width of screen.  If
  856. *--                               specified, will not be less than length of
  857. *--                               message.
  858. *-------------------------------------------------------------------------------
  859.  
  860.    parameters nQuan,cWindCol,cFillCol1,cFillCol2,cMessage,nWindWidth
  861.    private lMessage,x, nParms
  862.    lMessage  = iif(.not. isblank(cMessage), .t., .f.)  && was message passed?
  863.     *-- find out # of parameters passed ...
  864.     if val(right(version(),3)) > 1.1
  865.         nParms = pcount()
  866.     else
  867.         nParms = 6
  868.     endif
  869.    nWindWidth = iif(nParms = 6,nWindWidth,78) && all the way if width not passed
  870.    nWindWidth = min(nWindWidth,78)            && width param > 78 not allowed
  871.    *-- window width can't be narrower than messsage, so....
  872.    nWindWidth = iif(lMessage,max(nWindWidth,len(cMessage) + 2),nWindWidth)
  873.    *-- skip this section if we've been here before
  874.    *-- this procedure called from inside a loop
  875.    *-- following section ignored except on first iteration thru loop
  876.    if type("nTimes") = "U"  && check to see if we been here before
  877.       save screen to sProgBar
  878.       public nFactor,nTimes,wPrevWind  && make these available on all iterations
  879.        *-- was a window active?
  880.        wPrevWind = window()
  881.       nProgLine = iif(set("status") = "ON",20,22)  && don't overwrite status
  882.       *-- determine how wide the window needs to be
  883.       define window wProgBar from ;
  884.      nProgLine - iif(lMessage, 2, 1),(80 - (nWindWidth + 2)) / 2 ;
  885.      to nProgLine + 1,(80 + (nWindWidth + 2)) / 2 - 1 ;
  886.      double color &cWindCol
  887.       activate window wProgBar
  888.       @ 0,0 say replicate(".",nWindWidth - 1)  && the ruler
  889.       @ 0,0 say "0%"                        && and some gradation %'s
  890.       @ 0,nWindWidth / 4 - 2 say "25%"
  891.       @ 0,nWindWidth / 2 - 2 say "50%"
  892.       @ 0,3*(nWindWidth / 4) - 2 say "75%"
  893.       @ 0,nWindWidth - 4 say "100%"
  894.       @ 0,0 fill to 0,nWindWidth - 1 color &cFillCol1  && color of ruler before process
  895.       if lMessage
  896.      @ 1,(nWindWidth - (len(cMessage))) / 2 say cMessage 
  897.       endif
  898.       nFactor = nQuan/nWindWidth   && e.g. how many records per bar part(cols)
  899.       nTimes = 0  && times thru loop
  900.    endif      && type("nTimes") = "U"
  901.  
  902.    *-- this section will be processed as many times as required by nQuan
  903.    nTimes = nTimes + 1
  904.    @ 0,0 fill to 0,int(nTimes / nFactor) ;
  905.      - iif(int(nTimes / nFactor) - 1 >= 0, 1, 0) ;
  906.      color &cFillCol2    && color of ruler as processing takes place
  907.    if nTimes = nQuan  && we done
  908.       x = inkey(.5)   && leave on screen just a liitle while after completion
  909.       *-- cleanup your mess
  910.       deactivate window wProgBar
  911.       release window wProgBar
  912.       restore screen from sProgBar
  913.       release screen sProgBar
  914.         *-- Reactivate window if it existed
  915.         if .not. isblank(wPrevWind)
  916.             activate window &wPrevWind
  917.         endif
  918.       release nProgBar,nFactor,nTimes,lMessage,x,wPrevWind
  919.    endif  && nTimes = nQuan
  920. RETURN
  921. *-- EoP: ProgBar
  922.  
  923. FUNCTION Alert2
  924. *-------------------------------------------------------------------------------
  925. *-- Programmer..: Adam L. Menkes (SUPREME1)
  926. *-- Date........: 11/16/1992
  927. *-- Notes.......: This function based on Alert2()
  928. *--               This routine creates a popup on the screen with a title and
  929. *--               one line message, forcing the user to notice the message.
  930. *--               The user must use the mouse on the 'OK' pad, press <Esc> or
  931. *--               press <Enter> to move on in the program that called this
  932. *--               function.
  933. *-- Written for.: dBASE IV, 1.5
  934. *-- Rev. History: Alert2()
  935. *--               Modified to accept the <Enter> key by Ken Mayer.
  936. *--               06/19/1992 -- Copied from Adam's original, uses a window,
  937. *--                 shadow, and programmer defineable colors.
  938. *--               07/29/1992 -- Joey stepped in and made some modifications
  939. *--                 that seem to have helped as well, including dealing with
  940. *--                 the keyboard buffer.
  941. *--               10/09/1992 -- minor change -- title is now same color as
  942. *--                 the "pad".
  943. *--               Alert22()
  944. *--               11/12/1992 -- changed to look more like a Win 3.0/3.1
  945. *--                 window by printing a special 'line' below the title.
  946. *--                 Also removed hard coding which forced border to DOUBLE
  947. *--                 so that if called with border set to NONE, gives even more
  948. *--                 Win-like appearance.  Calls a new function written for this
  949. *--                 technique, but can be used in other programs.
  950. *--               11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer)
  951. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  952. *--               CENTER               Procedure in PROC.PRG
  953. *--               JUSTIFY()            Function in PROC.PRG
  954. *--               COLORBRK()           Function in PROC.PRG
  955. *--               FBCLRBRK()           Function in PROC.PRG 
  956. *-- Called by...: Any
  957. *-- Usage.......: Alert2("<cTitle>","<cMessage>","<cColor>"[,"<cBorder>"])
  958. *-- Example.....: ** if no border, I suggest colors which will contrast
  959. *--                  with the active screen or window
  960. *--               lX = Alert2("Print Aborted","You pressed <ESC>",;
  961. *--                           "rg+/r,w+/b,rg+/r","NONE")
  962. *-- Returns.....: Logical
  963. *-- Parameters..: cTitle   = Title line
  964. *--               cMessage = One line message (up to 75 characters)
  965. *--               cColor   = Colors: <window forg/back>,<pad> (and title),<box>
  966. *--               cBorder  = Border type (DOUBLE, SINGLE, NONE, PANEL) -- 
  967. *--                          optional -- will default to your setting
  968. *-------------------------------------------------------------------------------
  969.  
  970.    parameters cTitle, cMessage, cColor, cBorder
  971.    private wWindow,nRow,nCol,mPad,cTempCol,cColorF,cColorB,cColorAll,lNoBorder
  972.  
  973.    wWindow = WINDOW()                  && save current Window
  974.    save screen to sTemp                && save the screen
  975.    activate screen
  976.    cDummykey = inkey()                 && clear out keyboard buffer
  977.     cOldBorder = set("BORDER")       && get old border setting
  978.     if .not. type("CBORDER") = "L"      && if user set border ...
  979.         set border to &cBorder           && start NEW border setting
  980.     endif
  981.    lNoBorder = set("BORDER") = "NONE"  && is there a border?
  982.  
  983.    *-- get window coordinates
  984.    *-- this centers from top to bottom, depending on monitor setup ...
  985.    nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
  986.    *-- add rows, number depends on border, so the Window is large enough ...
  987.    if lNoBorder
  988.       nBRRow = nULRow + 4
  989.    else
  990.       nBRRow = nULRow + 6
  991.    endif
  992.    *-- left column ...
  993.    nULCol = 36 - (max(len(cTitle),len(cMessage))/2)    && center left-right
  994.    *-- right column ...
  995.    nBRCol = nULCol + max(len(cTitle),len(cMessage))+4  && right side?
  996.    *-- Window width ...
  997.    nWidth = nBRCol - nULCol - 1
  998.  
  999.    *-- define window
  1000.    activate screen
  1001.  
  1002.    Define window wAlert from nULRow,nULCol to nBRRow,nBRCol ;
  1003.        color &cColor.
  1004.  
  1005.    *-- display shadow
  1006.    do shadow with nULRow,nULCol,nBRRow,nBRCol
  1007.  
  1008.    *-- start 'er up ...
  1009.    activate window wAlert
  1010.  
  1011.    *-- display title
  1012.    cTempCol = colorbrk(cColor,2)
  1013.    if len(cTitle) < nWidth
  1014.        cTitle = justify(cTitle,iif(lNoBorder,nWidth+2,nWidth),"C")
  1015.        if len(cTitle) < nWidth
  1016.        cTitle = cTitle + " "
  1017.        endif
  1018.    endif
  1019.  
  1020.    *-- display  a new type type line to look more like Win
  1021.    cColorF   = FBClrBrk("B",cTempCol)
  1022.    cColorB   = FBClrBrk("B",colorbrk(cColor,1))
  1023.    cColorAll = cColorF + "/" + cColorB
  1024.    if lNoBorder
  1025.      do center with 0,nWidth + 3,"&cTempCol",cTitle
  1026.      *-- chr(223) looks like this --> ▀ <--
  1027.      @ 1,0 say replicate(chr(223),nWidth + 2) color &cColorAll
  1028.    else
  1029.      do center with 0,nWidth,"&cTempCol",cTitle
  1030.      @ 1,0 say replicate(chr(223),nWidth) color &cColorAll
  1031.    endif
  1032.  
  1033.    *-- display message
  1034.    do center with 2,nWidth,"",cMessage
  1035.  
  1036.    *-- define/display a very small menu (one pad)
  1037.    define menu mAlert
  1038.    define pad pPad1 of mAlert prompt "[OK]" at 4,(nWidth/2-2)
  1039.    on selection pad pPad1 of mAlert deactivate menu
  1040.  
  1041.    *-- added by Ken to deal with <Enter>
  1042.    on key label ctrl-M keyboard "{27}"
  1043.  
  1044.    *-- start it up
  1045.    activate menu mAlert
  1046.  
  1047.    *-- deal with user 'input'
  1048.    mPad = pad()
  1049.    deactivate window wAlert
  1050.    release window wAlert
  1051.  
  1052.    *-- restore environment, free up RAM by releasing things
  1053.    on key label ctrl-m
  1054.    restore screen from sTemp
  1055.    release screen sTemp
  1056.    release menu mAlert
  1057.    if "" # wWindow
  1058.        activate window &wWindow
  1059.    endif
  1060.     set border to &cOldBorder
  1061.     
  1062. RETURN .not. "" = mPad  && not empty pad?
  1063. *-- EoF: Alert2()
  1064.  
  1065. PROCEDURE Shadow
  1066. *-------------------------------------------------------------------------------
  1067. *-- Programmer..: Ashton-Tate
  1068. *-- Date........: 01/27/1992
  1069. *-- Notes.......: Creates a shadow for a window (taken from the dBASE IV
  1070. *--               picklist functions)
  1071. *-- Written for.: dBASE IV, 1.1
  1072. *-- Rev. History: 05/23/1991 - original procedure.
  1073. *--               12/14/1991 - Modified by Jim Magnant (TXAGGIE) - to check
  1074. *--               for columns exceeding 79, and temporarily change last col.
  1075. *--               value (so routine doesn't "blow up").
  1076. *--               01/27/1992 -- Modifiedy by Ken Mayer to check for bottom
  1077. *--               of screen, based on what Jim did above. No further than 23.
  1078. *-- Calls.......: None
  1079. *-- Called by...: Too many to list ...
  1080. *-- Usage.......: do shadow with <nULRow>,<nULCol>,<nBRRow>,<nBRCol>
  1081. *-- Example.....: save screen to sMain
  1082. *--               activate screen
  1083. *--               define window wError from 5,15 to 15,65 double color;
  1084. *--                    rg+/r,rg+/r,rg+/r
  1085. *--               do shadow with 5,15,15,65
  1086. *--               activate window WError
  1087. *--                && perform actions in window
  1088. *--               deactivate window WError
  1089. *--               release window WError
  1090. *--               restore screen from sMain
  1091. *--               release screen sMain
  1092. *-- Returns.....: None
  1093. *-- Parameters..: nULRow = Upper Left Row position
  1094. *--               nULCol = Upper Left Column position (x,y)
  1095. *--               nBRRow = Bottom Right Row position
  1096. *--               nBRCol = Bottom Right Column position (x2,y2)
  1097. *-------------------------------------------------------------------------------
  1098.  
  1099.     parameters nULRow,nULCol,nBRRow,nBRCOL
  1100.     private nTempRow,nTempCol,nIncRow,nIncCol
  1101.  
  1102.     nTempRow = iif(nBRRow+1>23,23,nBRRow+1)
  1103.     nTempCol = iif(nBRCol+2>79,79,nBRCol+2)
  1104.     nIncRow = 1
  1105.     nIncCol = (nBRCol-nULCol) / (nBRRow-nULRow)
  1106.     do while nTempRow <> nULRow .or. nTempCol <> nULCol+2
  1107.         nRightCol = nBRCol
  1108.         nBRCol = iif(nBRCol + 2 > 79,77,nBRCol)
  1109.         nBotRow = nBRRow
  1110.         nBRRow = iif(nBRRow + 1 > 23,22,nBRRow)
  1111.         @ nTempRow,nTempCol fill to nBRRow+1,nBRCol+2 color n+/n
  1112.         nBRCol = nRightCol
  1113.         nBRRow = nBotRow
  1114.         nTempRow = iif(nTempRow<>nULRow,nTempRow - nIncRow,nTempRow)
  1115.         nTempCol = iif(nTempCol<>nULCol+2,nTempCol - nIncCol,nTempCol)
  1116.         nTempCol = iif(nTempCol<nULCol+2,nULCol+2,nTempCol)
  1117.     enddo
  1118.     
  1119. RETURN
  1120. *-- EoP: Shadow
  1121.  
  1122. FUNCTION VPick
  1123. *-------------------------------------------------------------------------------
  1124. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1125. *-- Date........: 06/08/1992
  1126. *-- Notes.......: Keith wanted a multiple choice picklist routine for use
  1127. *--               with a mouse (or other) ... he got the idea for the AT-USER
  1128. *--               system which he was Beta Testing. Here 'tis ...
  1129. *--                This creates a quick pick-list for multiple-choice, single-
  1130. *--                character input. The first letter of the selected bar is
  1131. *--                returned. If <Esc> is pressed, a null string is returned.
  1132. *--               NOTE: If using this with dBASE IV, 1.1, you must supply
  1133. *--               a parameter for each option below.
  1134. *-- Written for.: dBASE IV, 1.5
  1135. *-- Rev. History: 06/02/1992 -- Keith first gave this to Ken Mayer to use with
  1136. *--               the BORUSER system.
  1137. *--               06/08/1992 -- Modified to allow passing of a color memvar,
  1138. *--               and then to use explicit color definitions based on it.
  1139. *--               11/09/1992 - Joey Carrol modified to allow use of function
  1140. *--               when another window is active, and to insure color integrity
  1141. *-- Calls.......: COLORBRK()          Function in PROC.PRG
  1142. *--               RECOLOR             Procedure in PROC.PRG
  1143. *-- Called by...: Any
  1144. *-- Usage.......: ?VPick(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>",;
  1145. *--                 <lShadow>,<cColor>)
  1146. *-- Example.....: cHow = VPick(12,15,"~BorBBS ID~Lastname",;
  1147. *--                        "How do you want the data sorted?","Choose one",;
  1148. *--                        "rg+/gb,w+/b,rg+/gb")
  1149. *-- Returns.....: First letter of bar selected, or null if <Esc>.
  1150. *-- Parameters..: nRow     = is a numeric value for the top row of the popup.
  1151. *--               nCol     = is a numeric value for the left column.
  1152. *--               cOptions = is a string of options with each preceded by
  1153. *--                       '~', e.g. "~Screen~Printer~Text File~Return to Menu"
  1154. *--               cTitle   = is an optional title, used for the popup heading
  1155. *--               cMessage = is an optional message string for when the popup 
  1156. *--                          is activated on the screen.
  1157. *--               lShadow  = is a logical value indicating whether or not a 
  1158. *--                          shadow is to be placed under the popup.
  1159. *--               cColor   = Colors to be used. Should have three parts --
  1160. *--                          <normal/unselected text>,<highlighted text>,
  1161. *--                          <border>, using the format "Foreground/Background"
  1162. *--                          for each. So examine the example above.
  1163. *-------------------------------------------------------------------------------
  1164.     
  1165.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow,cColor
  1166.     private nRow,nCol,cOptions,cTitle,cMessage,lShadow,cTempCol,cCurColor
  1167.     
  1168.     *-- get number of parameters, and a few setup steps ...
  1169.     if val(right(version(),3)) > 1.1  && if version of dBASE (RunTime) > 1.1
  1170.        nParameters = pcount()
  1171.     else
  1172.         nParameters = 7
  1173.     endif
  1174.    nCount = 0
  1175.    cReturn = ""
  1176.    cOptions = trim(cOptions)
  1177.    cDispMesg = ""
  1178.    *-- if number of parameters greater/equal to 5, we may have a message
  1179.    *-- at the bottom of the screen ...
  1180.    if nParameters >= 5
  1181.       if len(cMessage) > 0
  1182.      cDispMesg = "MESSAGE "+"'"+cMessage+"'"
  1183.       endif
  1184.    endif
  1185.    
  1186.    *-- make it work even if a window is active.
  1187.    wPrevWind = window()
  1188.    activate screen
  1189.  
  1190.    *-- define the popup
  1191.    define popup pPickList from nRow,nCol &cDispMesg.
  1192.    nMessage1 = 0
  1193.    *-- if we have 4 or more parameters, one of them is the title ...
  1194.    *-- this requires that the first two bars of the menu be skipped ...
  1195.    if nParameters >= 4
  1196.       if len(cTitle) > 0
  1197.      cTitle = " "+cTitle+" "
  1198.      nMessage1 = len(cTitle)
  1199.      nCount = 2
  1200.       endif
  1201.    endif
  1202.  
  1203.     *-- save current colors
  1204.     cCurColor = set("ATTRIBUTES")
  1205.     *-- set new ones
  1206.     cTempCol = colorbrk(cColor,1)
  1207.     set color of normal  to &cTempCol
  1208.     set color of message to &cTempCol
  1209.     cTempCol = colorbrk(cColor,2)
  1210.     set color of highlight to &cTempCol
  1211.     cTempCol = colorbrk(cColor,3)
  1212.     set color of box to &cTempCol
  1213.     
  1214.    *-- now we start parsing the options for the menu. These must have
  1215.    *-- a tilde between each, so we look for the first one, and then
  1216.    *-- look again to see if there's another after that.
  1217.  
  1218.    nPos1 = at("~",cOptions)                        && Look for first tilde
  1219.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop ...
  1220.       if nPos1 > 0
  1221.      cSub = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1222.      nPos2 = at("~",cSub)
  1223.      if nPos2 = 0
  1224.         nPos2 = len(cSub)
  1225.      else
  1226.         nPos2 = nPos2 - 1
  1227.      endif
  1228.      cOptString = " "+left(cSub,nPos2)+" "
  1229.      if len(cOptString) > nMessage1
  1230.         nMessage1 = len(cOptString)
  1231.      endif
  1232.      *-- define the actual 'bar' of the menu/picklist ...
  1233.      nCount = nCount + 1
  1234.      define bar nCount of pPickList prompt cOptString
  1235.      cOptions = cSub
  1236.       endif
  1237.       nPos1 = at("~",cOptions)
  1238.    enddo  && end of parsing loop
  1239.  
  1240.    *-- now we deal with defining the actual picklist ...
  1241.    if nCount > 0             && if we have something to put in the list ...
  1242.       if nParameters >= 4    && if we have a title for the top ...
  1243.      if len(cTitle) > 0
  1244.         if len(cTitle) < nMessage1
  1245.            cTitle = trim(ltrim(cTitle))
  1246.            cTitle = space((nMessage1-len(cTitle)) / 2) + cTitle
  1247.         endif
  1248.         define bar 1 of pPickList prompt cTitle skip
  1249.         define bar 2 of pPickList prompt replicate(chr(196),nMessage1) skip
  1250.      endif
  1251.       endif
  1252.       *-- define what to do when a choice is made ...
  1253.       on selection popup pPickList deactivate popup
  1254.       *-- if we have a shadow, let's save screen and do the shadow
  1255.       *-- before popping up the picklist
  1256.         if nParameters => 6
  1257.           if lShadow
  1258.           save screen to sPickScr
  1259.        @ nRow+1,nCol+2 fill to nRow+nCount+2,nCol+nMessage1+3 color w/n
  1260.           endif
  1261.         else
  1262.             lShadow = .f.
  1263.         endif
  1264.       *-- there we are ...
  1265.       activate popup pPickList
  1266.  
  1267.       *-- cleanup
  1268.       if lShadow
  1269.     restore screen from sPickScr
  1270.     release screen sPickScr
  1271.       endif
  1272.  
  1273.       *-- deal with what to 'return' ...
  1274.       if lastkey() = 27
  1275.      cReturn = ""
  1276.       else
  1277.      cReturn = substr(prompt(),2,1)
  1278.       endif
  1279.  
  1280.    endif && nCount > 0
  1281.  
  1282.     *-- we're done with it ... return it back to the electronic byte storage
  1283.     *-- bins ... 
  1284.    release popup pPickList
  1285.     do ReColor with cCurColor
  1286.     
  1287.     *-- was there an existing window?
  1288.     if .not. isblank(wPrevWind)
  1289.         activate window &wPrevWind
  1290.     endif
  1291.     
  1292. RETURN cReturn
  1293. *-- EoF: VPick()
  1294.  
  1295. FUNCTION HPick
  1296. *-------------------------------------------------------------------------------
  1297. *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
  1298. *-- Date........: 11/09/1992
  1299. *-- Notes.......: Creates a horizontal pick list for multiple-choice single-
  1300. *--               character input.  The first letter of the selected pad is 
  1301. *--               returned.  If <ESC> is pressed, a null string is returned.
  1302. *-- Written for.: dBASE IV, 1.1, 1.5
  1303. *-- Rev. History: 06/12/1992 -- Original
  1304. *--               11/09/1992 - Modified to allow use when another window is
  1305. *--               active, and to ensure color integrity (Joey Carroll).
  1306. *-- Calls.......: COLORBRK()           Function in PROC.PRG
  1307. *--               RECOLOR              Procedure in PROC.PRG
  1308. *-- Called by...: Any
  1309. *-- Usage.......: HPICK(<nRow>,<nCol>,"<cOptions>","<cTitle>","<cMessage>";
  1310. *--                     <lShadow>,"<cColor>")
  1311. *-- Example.....: x=HPick(8,5,"~Screen~Printer~Text File~Return to Menu",;
  1312. *--                       "Output Options","Select one, or <Esc> to exit",;
  1313. *--                       .t.,"rg+/gb,w+/b,rg+/gb")
  1314. *-- Returns.....: First letter of selected 'pad', or null if <Esc>.
  1315. *-- Parameters..: nRow      = a numeric value for the top row of the popup.
  1316. *--               nCol      = a numeric value for the left column of the popup.
  1317. *--               cOptions  = a string of options with each preceded by '~',
  1318. *--                           e.g. "~Screen~Printer~Text File~Return to Menu"
  1319. *--               cTitle    = an optional title, used for the popup heading
  1320. *--               cMessage  = an optional message string for when the popup 
  1321. *--                           is activated on the screen.
  1322. *--               lShadow   = a logical value indicating whether or not a 
  1323. *--                           shadow is to be placed under the popup.
  1324. *--               cColor    = Colors passed to function in format:
  1325. *--                            <Text/Unselected Pad>,<Selected Pad>,<Border>
  1326. *-------------------------------------------------------------------------------
  1327.  
  1328.     parameters nRow,nCol,cOptions,cTitle,cMessage,lShadow, cColor
  1329.     private cPickColor,cTempCol
  1330.    *-- get number of parameters, and a few setup steps
  1331.     *-- if version 1.5 or later, # of parms is optional ...
  1332.     if val(right(version(),3)) > 1.1  && if version of dBASE > 1.1
  1333.         nParameters = pcount()
  1334.     else
  1335.         nParameters = 7
  1336.     endif
  1337.    nCount = 0
  1338.    nStartCol = nCol
  1339.    cOptions = trim(cOptions)
  1340.    cDispMess = ""
  1341.     
  1342.     *-- make it work even if a window is active
  1343.     wPrevWind = window()
  1344.     activate screen
  1345.     
  1346.     *-- save current colors, set up colors for this routine
  1347.     cPickColor = set("ATTRIBUTES")
  1348.     cTempCol = colorbrk(cColor,1)
  1349.     set color of normal to &cTempCol
  1350.     set color of message to &cTempCol
  1351.     cTempCol = colorbrk(cColor,2)
  1352.     set color of highlight to &cTempCol
  1353.     cTempCol = colorbrk(cColor,3)
  1354.     set color of box to &cTempCol
  1355.     
  1356.    cPadName = "p"
  1357.     *-- if # of parameters => 5, we may have a message at the bottom of the
  1358.     *-- screen ...
  1359.    if nParameters >= 5
  1360.       if len(cMessage) > 0
  1361.      cDispMess = "MESSAGE "+"'"+cMessage+"'"
  1362.       endif
  1363.    endif
  1364.     *-- start defining the menu ...
  1365.    define menu mHPick &cDispMess.
  1366.    if nParameters >= 4
  1367.       if len(cTitle) > 0
  1368.      cTitle = " "+cTitle+" "
  1369.       endif
  1370.    endif
  1371.     
  1372.     *-- here, we have to parse the cOptions field for the tilde "~" character,
  1373.     *-- which is how we know we have a new pad ...
  1374.    nPos1 = at("~",cOptions)                        && position of first tilde
  1375.    do while (len(cOptions) > 0) .and. (nPos1 > 0)  && parsing loop
  1376.       if nPos1 = 0 .and. (len(cOptions) > 0)
  1377.      nPos1 = len(cOptions)
  1378.       endif
  1379.       if nPos1 > 0
  1380.      cSubString = substr(cOptions,nPos1+1,len(cOptions)-nPos1)
  1381.      nPos2 = at("~",cSubString)
  1382.      if nPos2 = 0
  1383.         nPos2 = len(cSubString)
  1384.      else
  1385.         nPos2 = nPos2 - 1
  1386.      endif
  1387.      cOptString = " "+left(cSubString,nPos2)+" "
  1388.      nCount = nCount + 1
  1389.      cPadName = "p"+ltrim(trim(str(nCount)))
  1390.      define pad &cPadName of mHPick prompt cOptString at nRow,nCol
  1391.      nCol = nCol + len(cOptString)
  1392.      on selection pad &cPadName of mHPick deactivate menu
  1393.      cOptions = cSubString
  1394.       endif
  1395.       nPos1 = at("~",cOptions)
  1396.    enddo
  1397.  
  1398.     *-- done figure that out. On to more stuff ...
  1399.    save screen to sPickList
  1400.     *-- do we have a shadow?
  1401.    if lShadow
  1402.       @ nRow,nStartCol+2 fill to nRow+2,nCol+2
  1403.    endif
  1404.     *-- draw border
  1405.    @ nRow-1,nStartCol-1 to nRow+1,nCol
  1406.     *-- display 'title'
  1407.    if len(cTitle) > 0
  1408.       @ nRow-1,nStartCol+1 say cTitle
  1409.    endif
  1410.     *-- start 'er up ...
  1411.    activate menu mHPick
  1412.  
  1413.     *-- that's it ... return screen to it's original
  1414.     *-- state ...
  1415.    restore screen from sPickList
  1416.     release screen sPickList
  1417.     
  1418.     *-- deal with user keystroke/selection ...
  1419.    if lastkey() = 27
  1420.       cReturn = ""
  1421.    else
  1422.       cReturn = substr(prompt(),2,1)
  1423.    endif
  1424.  
  1425.     *-- cleanup.
  1426.    release menu mHPick
  1427.     do ReColor with cPickColor  && reset colors
  1428.  
  1429.     *-- was there an existing window?
  1430.     if .not. isblank(wPrevWind)
  1431.         activate window &wPrevWind
  1432.     endif
  1433.  
  1434. RETURN cReturn
  1435. *-- EoF: HPick()
  1436.  
  1437. *===============================================================================
  1438. * NEW "3-D" ROUTINES -- These can be used in place of the "normal" routines
  1439. * above. Watch carefully -- there are differences in parameters.
  1440. *===============================================================================
  1441. FUNCTION YesNo4
  1442. *-------------------------------------------------------------------------------
  1443. *-- Programmer..: Miriam Liskin
  1444. *-- Date........: 03/15/1993
  1445. *-- Notes.......: Asks a yes/no question in a dialog window/box
  1446. *--               Made to look 3-D, removed COLOR parameter, so we could
  1447. *--               do this with Borland's STEEL GREY look ... (and it works
  1448. *--               with other colors ...)
  1449. *--               WARNING: If it matters to you -- this dialog box is 2 columns
  1450. *--               wider, and two rows taller than previous versions.
  1451. *-- Written for.: dBASE IV, 1.5
  1452. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer to become a function
  1453. *--               04/29/1991 - Modified by Ken Mayer add shadow
  1454. *--               05/13/1991 - Modified by Ken Mayer remove need for extra 
  1455. *--                            procedures (YES/NO) that were used for returning
  1456. *--                            values from Menu
  1457. *--                            (suggested by Clinton L. Warren (VBCES))
  1458. *--               11/15/1991 - Copied YesNo, modified to allow "location" 
  1459. *--                            options -- useful for some screens ...
  1460. *--               01/20/1992 - Modified by Martin Leon (HMAN) to allow user to
  1461. *--                            press 'Y' or 'N' and have them recognized ...
  1462. *--               04/22/1992 - Modified by Ken Mayer adding CLEAR TYPEAHEAD,
  1463. *--                            as occaisional problems appear otherwise.
  1464. *--               06/08/1992 - Modified by same for explicit color sets.
  1465. *--               03/15/1993 -- Modified to look 3-D by playing with borders.
  1466. *--                             (I got the idea from the Compiler flier ...)
  1467. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1468. *--               CENTER               Procedure in PROC.PRG
  1469. *--               BORD3D               Procedure in PROC.PRG
  1470. *-- Called by...: Any
  1471. *-- Usage.......: YesNo4(<lAnswer>,"<cWhere>",;
  1472. *--                                "<cMess1>","<cMess2>","<cMess3>",<cColor>;
  1473. *--                                [,<nStyle>])
  1474. *-- Example.....: if YesNo4(.t.,"UL","Do You Really Wish To Delete?",;
  1475. *--                            "This will destroy the data";
  1476. *--                             "in this record.","rg+/gb,w+/n,rg+/gb",1)
  1477. *--                  delete
  1478. *--               else
  1479. *--                  skip
  1480. *--               endif
  1481. *--
  1482. *--                 The middle set of colors should be different, as they
  1483. *--                 will be the colors of the YES/NO selections ...
  1484. *--                 Options may be blank by using nul values ("")
  1485. *-- Returns.....: .t./.f. depending on user's choice from menu
  1486. *-- Parameters..: lAnswer  = default value (Yes or No) for menu
  1487. *--               cWhere   = location on screen:
  1488. *--                             "UL" = Upper Left
  1489. *--                             "UC" = Upper Center
  1490. *--                             "UR" = Upper Right
  1491. *--                             "CL" = Center Left
  1492. *--                             "CC" = Center Center
  1493. *--                             "CR" = Center Right
  1494. *--                             "BL" = Bottom Left
  1495. *--                             "BC" = Bottom Center
  1496. *--                             "BR" = Bottom Right
  1497. *--               cMess1   =  First line of Message
  1498. *--               cMess2   =  Second line of message (may be nul = "")
  1499. *--               cMess3   =  Third line of message  (may be nul = "")
  1500. *--               cColor   =  Colors: forg/back,forg/back,forg/back
  1501. *--                           where the first set is window/text color,
  1502. *--                           next is highlighted pad color,
  1503. *--                           last is border color
  1504. *--               nStyle   =  Optional -- 1 = raised 3-d Border,
  1505. *--                                       2 = inset 3-d Border
  1506. *--                           (Note that this is passed directly to BORD3D)
  1507. *-------------------------------------------------------------------------------
  1508.  
  1509.     parameter lAnswer,cWhere,cMess1,cMess2,cMess3,cColor,nStyle
  1510.     private cExact,cW1,cW2,nULB,nBRR,nULC,nBRC
  1511.         
  1512.     cExact = set("EXACT")
  1513.     cWindow = window()     && save "window" name if there is one active
  1514.     save screen to sYesno
  1515.     
  1516.     *-- see what the user gave us ...
  1517.     if len(trim(cWhere)) > 0
  1518.         cW1 = upper(left(cWhere,1))  && first coordinate (vertical)
  1519.         cW2 = upper(right(cWhere,1)) && second coordinate (horizontal)
  1520.     else
  1521.         cW1 = "C"
  1522.         cW2 = "C"
  1523.     endif
  1524.     *-- deal with vertical placement
  1525.     do case
  1526.         case cW1 = "U"
  1527.             nULR =  1   && upper left row
  1528.             nBRR =  10   && bottom right row
  1529.         case cW1 = "C"
  1530.             nULR =  7
  1531.             nBRR = 16
  1532.         case cW1 = "B"
  1533.             nULR = 13
  1534.             nBRR = 22
  1535.     endcase
  1536.     *-- deal with horizontal placement
  1537.     do case
  1538.         case cW2 = "L"
  1539.             nULC =  5   && upper left column
  1540.             nBRC = 45   && bottom right column
  1541.         case cW2 = "R"
  1542.             nULC = 35
  1543.             nBRC = 75
  1544.         case cW2 = "C"
  1545.             nULC = 20
  1546.             nBRC = 60
  1547.     endcase
  1548.     
  1549.     activate screen
  1550.     define window wYesno from nULR,nULC to nBRR,nBRC NONE color &cColor.
  1551.     
  1552.     define menu mYesno
  1553.     define pad pYes of mYesno Prompt "[Yes]" at 7,12 
  1554.     define pad pNo  of mYesno Prompt "[No]"  at 7,27 
  1555.     on selection pad pYes of mYesno deactivate menu
  1556.     on selection pad pNo  of mYesno deactivate menu
  1557.     
  1558.     *-- start displaying it ... shadow, window ...
  1559.     do shadow with nULR,nULC,nBRR,nBRC
  1560.     activate window wYesno
  1561.     
  1562.     *-- do 3d border ...
  1563.     if pCount() < 7  && if optional parm not passed, set default
  1564.         nStyle = 1    &&   which is the 'raised' border
  1565.     endif
  1566.     do bord3d with 9,40,cColor,nStyle
  1567.     
  1568.     *-- display text
  1569.     do center with 2,40,"",left(cMess1,34)    && center the text
  1570.     do center with 4,40,"",left(cMess2,34)
  1571.     do center with 5,40,"",left(cMess3,34)
  1572.     *-- set 'y' or 'n' keys ...
  1573.    on key label Y keyboard IIF( PAD() = "PYES", "", CHR(19) )+chr(13)
  1574.    on key label N keyboard IIF( PAD() = "PNO",  "", CHR(4)  )+chr(13)
  1575.     clear typeahead
  1576.    if lAnswer
  1577.         activate menu mYesno pad pYes
  1578.     else
  1579.         activate menu mYesno pad pNo
  1580.     endif
  1581.    
  1582.     *-- reset system ...
  1583.     on key label Y
  1584.    on key label N
  1585.     deactivate window wYesno
  1586.     release window wYesno
  1587.     restore screen from sYesno
  1588.     release screen sYesno
  1589.     release menu mYesno
  1590.     if .not. isblank(cWindow)
  1591.         activate window &cWindow.
  1592.     endif
  1593.     set exact &cExact.
  1594.     
  1595. RETURN iif(pad()="PYES",.t.,.f.)
  1596. *-- EoF: YesNo4()
  1597.  
  1598. FUNCTION Alert4
  1599. *-------------------------------------------------------------------------------
  1600. *-- Programmer..: Adam L. Menkes (SUPREME1)
  1601. *-- Date........: 03/15/1993
  1602. *-- Notes.......: This function based on Alert3()
  1603. *--               This routine creates a popup on the screen with a title and
  1604. *--               one line message, forcing the user to notice the message.
  1605. *--               The user must use the mouse on the 'OK' pad, press <Esc> or
  1606. *--               press <Enter> to move on in the program that called this
  1607. *--               function.
  1608. *--               WARNING: If it matters to you, this dialog box is two rows
  1609. *--               higher, and two columns wider than previous versions.
  1610. *-- Written for.: dBASE IV, 1.5
  1611. *-- Rev. History: Original: 06/19/1992
  1612. *--               Alert2()
  1613. *--               Modified to accept the <Enter> key by Ken Mayer.
  1614. *--               06/19/1992 -- Copied from Adam's original, uses a window,
  1615. *--                 shadow, and programmer defineable colors.
  1616. *--               07/29/1992 -- Joey stepped in and made some modifications
  1617. *--                 that seem to have helped as well, including dealing with
  1618. *--                 the keyboard buffer.
  1619. *--               10/09/1992 -- minor change -- title is now same color as
  1620. *--                 the "pad".
  1621. *--               Alert3()
  1622. *--               11/12/1992 -- changed to look more like a Win 3.0/3.1
  1623. *--                 window by printing a special 'line' below the title.
  1624. *--                 Also removed hard coding which forced border to DOUBLE
  1625. *--                 so that if called with border set to NONE, gives even more
  1626. *--                 Win-like appearance.  Calls a new function written for this
  1627. *--                 technique, but can be used in other programs.
  1628. *--               11/16/1992 -- modified to add cBORDER parameter ... (K. Mayer)
  1629. *--               12/23/1992 -- tuned up centering of cTitle, cMessage, and
  1630. *--                 [OK] pad.  Eliminated calls to Center.prg by using Justify()
  1631. *--                 along with @ say.        (Joey Carroll)
  1632. *--               Alert4()
  1633. *--               03/15/1993 -- Modified by Ken Mayer to give 3-D border ...
  1634. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1635. *--               JUSTIFY()            Function in PROC.PRG
  1636. *--               COLORBRK()           Function in PROC.PRG
  1637. *--               FBCLRBRK()           Function in PROC.PRG 
  1638. *--               BORD3D               Procedure in PROC.PRG
  1639. *-- Called by...: Any
  1640. *-- Usage.......: Alert4("<cTitle>","<cMessage>","<cColor>"[,<nStyle>])
  1641. *-- Example.....: lX = Alert4("Print Aborted","You pressed <ESC>",;
  1642. *--                           "rg+/r,w+/b,rg+/r",2)
  1643. *-- Returns.....: Logical
  1644. *-- Parameters..: cTitle   = Title line
  1645. *--               cMessage = One line message (up to 75 characters)
  1646. *--               cColor   = Colors: <window forg/back>,<pad> (and title),<box>
  1647. *--               nStyle   = OPTIONAL: Style 1 (default) = raised border
  1648. *--                                    Style 2           = inset border
  1649. *-------------------------------------------------------------------------------
  1650.  
  1651.    parameters cTitle, cMessage, cColor, nStyle
  1652.    private wWindow,mPad,cTempCol,cColorF,cColorB,cColorAll
  1653.    private nWidth,nULRow,nULCol,nLRRow,nLRCol,cTitle2,cMessage2
  1654.  
  1655.    cTitle2 = " " + ltrim(trim(cTitle)) + " "      && don't jamb against walls
  1656.    cMessage2 = " " + ltrim(trim(cMessage)) + " "  && don't jamb against walls
  1657.    wWindow = WINDOW()                             && save current Window
  1658.    save screen to sTemp                           && save the screen
  1659.    activate screen
  1660.    cDummykey = inkey()                            && clear out keyboard buffer
  1661.     if pCount() < 4
  1662.         nStyle = 1
  1663.     endif
  1664.     
  1665.    *-- get window coordinates
  1666.    *-- this centers from top to bottom, depending on monitor setup ...
  1667.    nULRow = iif(val(right(set("DISPLAY"),2)) = 43,18,8)
  1668.    *-- add rows, number depends on border, so the Window is large enough ...
  1669.    nBRRow = nULRow + 8
  1670.  
  1671.    *-- left column ...
  1672.    nULCol = (40 - (max(len(cTitle2),len(cMessage2))/2)) -2 && center left-right
  1673.    *-- right column ...
  1674.    nBRCol = nULCol + max(len(cTitle2),len(cMessage2)) + 5
  1675.    *-- Window width ...
  1676.    nWidth = nBRCol - nULCol
  1677.  
  1678.    *-- define window (with no border so we can place the 3-D one on it ...)
  1679.    Define window wAlert from nULRow,nULCol to nBRRow,nBRCol NONE color &cColor.
  1680.  
  1681.    *-- display shadow
  1682.    do shadow with nULRow,nULCol,nBRRow,nBRCol
  1683.  
  1684.    *-- start 'er up ...
  1685.    activate window wAlert
  1686.  
  1687.     *-- put 3-D Border in there
  1688.     do BORD3D with (nBRRow-nULRow),nWidth,cColor, nStyle
  1689.  
  1690.    *-- display  a new type type line to look more like Win
  1691.    cTempCol = colorbrk(cColor,2)
  1692.    cColorF   = FBClrBrk("B",cTempCol)           && background of title bar text
  1693.    cColorB   = FBClrBrk("B",colorbrk(cColor,1)) && foreground of 'normal' text
  1694.    cColorAll = cColorF + "/" + cColorB          && color of 'special' line
  1695.    @ 2,3 say justify(cTitle2,nWidth - 5 ,"C");
  1696.                color &cTempCol.                 && the Title Bar
  1697.    *-- chr(223) looks like this --> ▀ <--
  1698.    @ 3,3 say replicate(chr(223),nWidth - 5) color &cColorAll  && make thicker
  1699.  
  1700.    *-- display message
  1701.    @ 4,3 say justify(cMessage2,nWidth - 5,"C")
  1702.    *-- define/display a very small menu (one pad)
  1703.    define menu mAlert
  1704.    define pad pPad1 of mAlert prompt "[OK]" at 6,((nWidth-5)/2)+1
  1705.    on selection pad pPad1 of mAlert deactivate menu
  1706.  
  1707.    *-- added by Ken to deal with <Enter>
  1708.    on key label ctrl-M keyboard "{27}"
  1709.  
  1710.    *-- start it up
  1711.    activate menu mAlert
  1712.  
  1713.    *-- deal with user 'input'
  1714.    mPad = pad()
  1715.    deactivate window wAlert
  1716.    release window wAlert
  1717.  
  1718.    *-- restore environment, free up RAM by releasing things
  1719.    on key label ctrl-m
  1720.    restore screen from sTemp
  1721.    release screen sTemp
  1722.    release menu mAlert
  1723.    if "" # wWindow
  1724.        activate window &wWindow
  1725.    endif
  1726.     
  1727. RETURN .not. "" = mPad  && not empty pad?
  1728. *-- EoF: Alert4()
  1729.  
  1730. FUNCTION YesNo5
  1731. *-------------------------------------------------------------------------------
  1732. *-- Programmer..: Kenneth J. Mayer
  1733. *-- Date........: 03/16/1993
  1734. *-- Notes.......: A version of the YESNO() routines in PROC.PRG, that will
  1735. *--               handle a long (up to 254 character) message string, is
  1736. *--               centered on the screen, and has a title bar kind of like
  1737. *--               a Windows dialog box ... (This version is a modification
  1738. *--               of YESNO3(), with a "3-D Border" added to it ...)
  1739. *--               WARNING: This dialog box is two rows taller and two columns
  1740. *--               wider than previous versions.
  1741. *-- Written for.: dBASE IV, 1.5
  1742. *-- Rev. History: 01/06/1993 -- Original
  1743. *--               03/16/1993 -- Added 3-D border
  1744. *-- Calls.......: Center               Procedure in PROC.PRG
  1745. *--               Shadow               Procedure in PROC.PRG
  1746. *--               WordWrap             Procedure in STRINGS.PRG
  1747. *--               ColorBrk()           Function in PROC.PRG
  1748. *--               FBClrBrk()           Function in PROC.PRG
  1749. *--               Justify()            Function in PROC.PRG
  1750. *--               Bord3D               Procedure in PROC.PRG
  1751. *-- Called by...: Any
  1752. *-- Usage.......: YesNo5(<lDefault>,<cTitle>,<cMessage>,<cColor>[,<nStyle>])
  1753. *-- Example.....: if YesNo5(.t.,"Test","This is a message of any length"+;
  1754. *--                         "up to 254 characters.",cWind1,2)
  1755. *-- Returns.....: logical
  1756. *-- Parameters..: lDefault  = Logical value, for the default menu pad (Yes/No)
  1757. *--               cTitle    = Title for title bar -- no longer than 30 
  1758. *--                           characters.
  1759. *--               cMessage  = Message - up to 254 characters in length.
  1760. *--               cColor    = "Standard" colors for window/menu/box
  1761. *--               nStyle    = Optional: nStyle = 1 means raised border
  1762. *--                                     nStyle = 2 means inset border
  1763. *-------------------------------------------------------------------------------
  1764.  
  1765.     parameters lDefault, cTitle, cMessage, cColor, nStyle
  1766.     private nULRow, nULCol, nBRRow, nBRCol, nLMargin, nRMargin, lWrap
  1767.     
  1768.     if pCount() < 5
  1769.         nStyle = 1
  1770.     endif
  1771.     
  1772.     *-- save it, so we can activate the screen and display a window on top
  1773.     *-- of whatever's there
  1774.     save screen to sYesNo
  1775.     
  1776.     *-- save window if there is one, and activate screen to be safe:
  1777.     wWindow = window()
  1778.     activate screen
  1779.     
  1780.     *-- now to define the coordinates ...
  1781.     nULCol = 20   && left side of box
  1782.     nBRCol = 60   && right side of box
  1783.     
  1784.     nWidth =  36  && width of dialog box ... 36 characters for text
  1785.     nHeight = int(len(cMessage)/nWidth)
  1786.     *-- if the remainder of the length of the message/width of box is > 0
  1787.     *-- we have one more line of text ...
  1788.     nHeight = nHeight + iif(mod(len(cMessage),nWidth)>0,1,0)  
  1789.     
  1790.     *-- deal with room for title, and menu at bottom (and 3-D Border)
  1791.     nHeight = nHeight + 8
  1792.     
  1793.     *-- row coordinates
  1794.     nULRow = (24-nHeight) / 2     && top row
  1795.     nBRRow = nULRow + nHeight
  1796.     
  1797.     *-- define the window
  1798.     define window wYesNo from nULRow,nULCol to nBRRow,nBRCol NONE color &cColor
  1799.     
  1800.     *-- now for the menu pads
  1801.     define menu mYesNo
  1802.     define pad pYes of mYesNo prompt "[Yes]" at nHeight - 2,10
  1803.     define pad pNo  of mYesNo prompt "[No]"  at nHeight - 2,25
  1804.     on selection pad pYes of mYesNo deactivate menu
  1805.     on selection pad pNo  of mYesNo deactivate menu
  1806.     
  1807.     *-- display it
  1808.     do shadow with nULRow,nULCol,nBRRow,nBRCol
  1809.     activate window wYesNo
  1810.     
  1811.     *-- put 3-D border on it
  1812.     do Bord3D with nHeight,nWidth+4,cColor,nStyle
  1813.     
  1814.     *-- display title
  1815.     if len(cTitle) < nWidth
  1816.         cTitle = justify(cTitle,35,"C")
  1817.         if len(cTitle) < 35
  1818.             cTitle = cTitle + " "
  1819.         endif
  1820.     endif
  1821.     cTempCol = colorbrk(cColor,2)
  1822.     cColorF  = FBClrBrk("B",cTempCol)
  1823.     cColorB  = FBClrBrk("B",colorbrk(cColor,1))
  1824.     cColorAll = cColorF + "/" + cColorB
  1825.     @2,3 say cTitle color &cTempCol
  1826.     @3,3 say replicate(chr(223),35) color &cColorAll.
  1827.     
  1828.     *-- display message
  1829.     do WordWrap with 4,4,cMessage,34
  1830.     
  1831.     *-- set Y/N keys for menu pad
  1832.     clear typeahead && just to be safe
  1833.     on key label Y keyboard iif(pad() = "PYES","",chr(19))+chr(13)
  1834.     on key label N keyboard iif(pad() = "PNO", "",chr(4) )+chr(13)
  1835.     
  1836.     *-- activate the menu
  1837.     if lDefault
  1838.         activate menu mYesNo pad pYes
  1839.     else
  1840.         activate menu mYesNo pad pNo
  1841.     endif
  1842.     
  1843.     *-- reset system
  1844.     on key label Y
  1845.     on key label N
  1846.     deactivate window wYesNo
  1847.     release window wYesNo
  1848.     restore screen from sYesNo
  1849.     release screen sYesNo
  1850.     release menu mYesNo
  1851.     if .not. isblank(wWindow)
  1852.         activate window &wWindow
  1853.     endif
  1854.  
  1855. RETURN iif(pad() = "PYES",.t.,.f.)
  1856. *-- EoF: YesNo5()
  1857.  
  1858. FUNCTION ErrorMsg2
  1859. *-------------------------------------------------------------------------------
  1860. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  1861. *-- Date........: 03/18/1993
  1862. *-- Notes.......: Display an error message in a Window: 
  1863. *--                           ** ERROR [#] **
  1864. *--
  1865. *--                              Message 1
  1866. *--                              Message 2
  1867. *--
  1868. *--                       Press any key to continue ...
  1869. *--
  1870. *--               WARNING: This version produces a dialog box that is two
  1871. *--               rows taller and two columns wider than previous. 
  1872. *-- Written for.: dBASE IV, 1.5
  1873. *-- Rev. History: 06/08/1992 -- Original
  1874. *--               03/18/1993 -- Modified to give the three-d border ...
  1875. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1876. *--               CENTER               Procedure in PROC.PRG
  1877. *--               ALLTRIM()            Function in PROC.PRG
  1878. *--               BORD3D               Procedure in PROC.PRG
  1879. *-- Called by...: Any
  1880. *-- Usage.......: ErrorMsg2("<cErr>","<cMess1>","<cMess2>","<cColor>"[,<nStyle>])
  1881. *-- Example.....: cDummy = errormsg2("3","This record","already exists!",;
  1882. *--                   "rg+/r,rg+/r,rg+/r",2)
  1883. *--               where "errornum" is an error number or nul,
  1884. *--               message2 and 3 should be 36 characters or less ...
  1885. *--               Colors should include foreground/background,;
  1886. *--                 foreground/background,foreground/background
  1887. *-- Returns.....: numeric value of keystroke user presses (cUser)
  1888. *-- Parameters..: cErr   = Error # (can be blank, but use "" for blank)
  1889. *--               cMess1 = Error message line 1
  1890. *--               cMess2 = Error message line 2
  1891. *--               cColor = Colors for text/window/border
  1892. *--               nStyle = OPTIONAL - style -- 1 = Raised, 2 = Recessed
  1893. *-------------------------------------------------------------------------------
  1894.     
  1895.     parameters cErr,cMess1,cMess2,cColor,nStyle
  1896.     private cCursor,cUser,cCurColor,cTempCol
  1897.     
  1898.     if pCount() < 5
  1899.         nStyle = 1
  1900.     endif
  1901.     
  1902.     save screen to sErr
  1903.     activate screen
  1904.     define window wErr from 7,19 to 16,61 NONE color &cColor.
  1905.     do shadow with 7,19,16,61
  1906.     activate window wErr
  1907.     
  1908.     *-- do border
  1909.     do Bord3d with 9,42,cColor,nStyle
  1910.     
  1911.     cCursor = set("CURSOR")
  1912.     set cursor off
  1913.     if len(trim(cErr)) > 0  && if there's an error number ...
  1914.         do center with 2,42,"","** ERROR "+alltrim(cErr)+" **"
  1915.     else                      && otherwise, don't display errornumber
  1916.         do center with 2,42,"","** ERROR **"
  1917.     endif
  1918.     do center with 4,42,"",left(cMess1,38)
  1919.     do center with 5,42,"",left(cMess2,38)
  1920.     do center with 7,42,"","Press any key to continue ..."
  1921.     cUser=inkey(0)
  1922.     
  1923.     set cursor &cCursor.
  1924.     deactivate window wErr
  1925.     release window wErr
  1926.     restore screen from sErr
  1927.     release screen sErr
  1928.     
  1929. RETURN cUser
  1930. *-- EoF: ErrorMsg()
  1931.  
  1932. FUNCTION Surround2
  1933. *-------------------------------------------------------------------------------
  1934. *-- Programmer..: Miriam Liskin
  1935. *-- Date........: 03/18/1993
  1936. *-- Notes.......: Displays a message surrounded by a box anywhere on 
  1937. *--               the screen -- this version centers automatically on
  1938. *--               the screen and gives a 3-D border ...
  1939. *-- Written for.: dBASE IV, 1.5
  1940. *-- Rev. History: 04/19/1991 - Modified by Ken Mayer (CIS: 71333,1030) to a 
  1941. *--               function from original procedure
  1942. *--               05/24/1991 -- Added shadow
  1943. *--               03/18/1993 -- Made 3D, and auto-center at "row".
  1944. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  1945. *--               BORD3D2              Procedure in PROC.PRG
  1946. *-- Called by...: Any
  1947. *-- Usage.......: surround2(<nLine>,"<cColor>","<cText>"[,<nStyle>])
  1948. *-- Example.....: cDummy = surround2(5,12,"RG+/GB",;
  1949. *--                        "Processing ... Do not Touch!",1)
  1950. *-- Returns.....: Nul/""
  1951. *-- Parameters..: nLine   = Line to display "surrounded" message at
  1952. *--               cColor  = Color variable/colors
  1953. *--               cText   = Text to be displayed inside box
  1954. *--               nStyle  = Style of border (1 = Raised, 2 = Recessed) OPTIONAL
  1955. *-------------------------------------------------------------------------------
  1956.     
  1957.     parameters nLine,cColor,cText,nStyle
  1958.     
  1959.     if pCount() < 4
  1960.         nStyle = 1
  1961.     endif
  1962.     
  1963.     *-- deal with border -- save old setting, set to single
  1964.     cBorder = set("BORDER")
  1965.     set border to single
  1966.     
  1967.     cText2 = " "+trim(cText)+" "             && add spaces to left and right
  1968.     nTextstart = (81-len(trim(cText2)))/2    && centered text on screen
  1969.     activate screen
  1970.     nTop    = nLine - 2
  1971.     nLeft   = nTextStart - 3       && back up 3
  1972.     nBottom = nLine + 2            && bottom row
  1973.     nRight  = (81-nTextStart) + 3  && right 3
  1974.     
  1975.     *-- draw shadow
  1976.     do shadow with nTop,nLeft,nBottom,nRight
  1977.     
  1978.     *-- fill in box
  1979.     @nTop,nLeft fill to nBottom,nRight color &cColor.
  1980.     
  1981.     *-- place border on top of it
  1982.     do bord3d2 with nTop,nLeft,nBottom,nRight,cColor,nStyle
  1983.     
  1984.     *-- finally, let's display the text ...
  1985.     @nLine, nTextstart say cText2 color &cColor. && display text
  1986.     
  1987. RETURN "" 
  1988. *-- EoF: Surround2()
  1989.  
  1990. FUNCTION ScrnHead2
  1991. *-------------------------------------------------------------------------------
  1992. *-- Programmer..: Miriam Liskin
  1993. *-- Date........: 03/17/1993
  1994. *-- Notes.......: Displays a heading on the screen in a box 2 
  1995. *--               spaces wider than the text, with a custom border (double 
  1996. *--               line top, single the rest)
  1997. *--               WARNING: This dialog box is two rows taller and two columns
  1998. *--               wider than previous versions. For the purposes of screen
  1999. *--               control, I moved this up to row 0 on the screen (you may
  2000. *--               need to SET SCOREBOARD OFF), and down one further row,
  2001. *--               so all screen changes should start at row 6, or you will
  2002. *--               destroy the shadow ... (it's only one extra row, but it
  2003. *--               will make a difference)
  2004. *-- Written for.: dBASE IV, 1.5
  2005. *-- Rev. History: 04/29/1991 - Modified by Ken Mayer to add shadow
  2006. *--               03/17/1993 -- Changed to give 3-D Border
  2007. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  2008. *--               BORD3D2              Procedure in PROC.PRG
  2009. *-- Called by...: Any
  2010. *-- Usage.......: scrnhead("<cColor>","<cText>"[,<nStyle>])
  2011. *-- Examples....: cDummy = ScrnHead("rg+/gb","Print Financial Report",1)
  2012. *-- Returns.....: nul/""
  2013. *-- Parameters..: cColor = Colors to display box/text in
  2014. *--               cText  = text to be displayed.
  2015. *--               nStyle = Type of 3-d Border (passed directly to procedure)
  2016. *--                        1 = raised, 2 = inset
  2017. *-------------------------------------------------------------------------------
  2018.  
  2019.     parameters cColor,cText, nStyle
  2020.     private nTextStart,cText2
  2021.     
  2022.     *-- if style parameter not passed, use default
  2023.     if pCount() < 3
  2024.         nStyle = 1
  2025.     endif
  2026.     
  2027.     *-- deal with border -- save old setting, set to single
  2028.     cBorder = set("BORDER")
  2029.     set border to single
  2030.     
  2031.     cText2 = " "+trim(cText)+" "             && ad spaces to left and right
  2032.     nTextstart = (81-len(trim(cText2)))/2    && centered text on screen
  2033.     activate screen
  2034.     nTop    = 0
  2035.     nLeft   = nTextStart - 3       && back up 3
  2036.     nBottom = 4                    && bottom row
  2037.     nRight  = (81-nTextStart) + 3  && right 3
  2038.     
  2039.     *-- draw shadow
  2040.     do shadow with nTop,nLeft,nBottom,nRight
  2041.     
  2042.     *-- fill in box
  2043.     @nTop,nLeft fill to nBottom,nRight color &cColor.
  2044.     
  2045.     *-- place border on top of it all
  2046.     do bord3d2 with nTop,nLeft,nBottom,nRight,cColor,nStyle
  2047.     
  2048.     *-- finally, let's display the text ...
  2049.     @2, nTextstart say cText2 color &cColor. && display text
  2050.  
  2051. RETURN ""
  2052. *-- EoF: ScrnHead()
  2053.  
  2054. PROCEDURE BORD3D
  2055. *-------------------------------------------------------------------------------
  2056. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  2057. *-- Date........: 03/15/1993
  2058. *-- Notes.......: Designed to take a dialog box that _doesn't_ have a border
  2059. *--               defined (NONE), and is a grey box (i.e., background is 'W' 
  2060. *--               for color) and give a 3-d border to it ... 
  2061. *--               ASSUMPTION: Dialog box is defined in a window ... (not
  2062. *--               using @...FILL TO ... command)
  2063. *-- Written for.: dBASE IV, 1.5
  2064. *-- Rev. History: 03/15/1993 -- Original
  2065. *-- Calls.......: COLORBRK()           Function in PROC.PRG
  2066. *--               BackColor()          Function in COLOR.PRG
  2067. *-- Called by...: Any (Specifically YESNO4())
  2068. *-- Usage.......: Do Bord3D with <nHeight>,<nWidth>,<cColor>,<nStyle>
  2069. *-- Example.....: Do Bord3D with 9,40,cWind1,2
  2070. *-- Returns.....: None
  2071. *-- Parameters..: nHeight  = height of dialog box 
  2072. *--               nWidth   = Width of dialog box
  2073. *--               cColor   = Color settings used for dialog box -- requires
  2074. *--                          at a minimum the colors for the text part 
  2075. *--                          (i.e, "rg+/r")
  2076. *--               nStyle   = 'Style' of border -- 1 = raised, 2 = inset
  2077. *-------------------------------------------------------------------------------
  2078.  
  2079.     parameters nHeight, nWidth, cColor, nStyle
  2080.     private nHeight2, nWidth2
  2081.     
  2082.     cBorder = set("BORDER")       && save border setting
  2083.     set border to single          && must be single for this ...
  2084.     
  2085.     *-- figure out colors
  2086.     cTextColor = colorbrk(cColor,1)
  2087.     cBackColor = backcolor(cTextColor)
  2088.     cHighColor = "W+/"+cBackColor
  2089.     cShadColor = "N/"+cBackColor
  2090.     
  2091.     *-- if style is 1, we do the commands for a 'raised' border
  2092.     *-- if style is 2, we do an 'inset' border
  2093.     if nStyle < 1 .or. nStyle > 2  && if not 1 or 2 ...
  2094.         nStyle = 1
  2095.     endif
  2096.     
  2097.     if nStyle = 1
  2098.         *-- Outside of "border"
  2099.         @0,0 to 0,nWidth   color &cHighColor.            && horizontal top
  2100.         @0,0 to nHeight, 0 color &cHighColor.            && vertical left  
  2101.         @0,0       say chr(218) color &cHighColor.       && upper left corner
  2102.         @nHeight,0 say chr(192) color &cHighColor.       && lower left corner
  2103.         @0,nWidth   to nHeight,nWidth color &cShadColor. && vertical right
  2104.         @nHeight, 1 to nHeight,nWidth color &cShadColor. && horizontal bottom
  2105.         @0,nWidth say chr(191) color &cShadColor.        && upper right corner
  2106.         @nHeight,nWidth say chr(217) color &cShadColor.  && lower right corner
  2107.     
  2108.         *-- inside of "border"
  2109.         nWidth2 = nWidth - 2
  2110.         nHeight2 = nHeight - 1
  2111.         @1,2 to 1,nWidth2 color &cShadColor.                 && horizontal top
  2112.         @1,2 to nHeight2,2 color &cShadColor.                && vertical left  
  2113.         @1,2 say chr(218) color &cShadColor.                 && upper left corner
  2114.         @nHeight2,2 say chr(192) color &cShadColor.          && lower left corner
  2115.         @1,nWidth2 to nHeight2,nWidth2 color &cHighColor.    && vertical right
  2116.         @nHeight2,3 to nHeight2,nWidth2 color &cHighColor.   && horizontal bottom
  2117.         @1,nWidth2 say chr(191) color &cHighColor.           && upper right corner
  2118.         @nHeight2,nWidth2 say chr(217) color &cHighColor.    && lower right corner
  2119.     
  2120.     else
  2121.         
  2122.         *-- Outside of "border"
  2123.         @0,0 to 0,nWidth   color &cShadColor.            && horizontal top
  2124.         @0,0 to nHeight, 0 color &cShadColor.            && vertical left  
  2125.         @0,0       say chr(218) color &cShadColor.       && upper left corner
  2126.         @nHeight,0 say chr(192) color &cShadColor.       && lower left corner
  2127.         @0,nWidth   to nHeight,nWidth color &cHighColor. && vertical right
  2128.         @nHeight, 1 to nHeight,nWidth color &cHighColor. && horizontal bottom
  2129.         @0,nWidth say chr(191) color &cHighColor.        && upper right corner
  2130.         @nHeight,nWidth say chr(217) color &cHighColor.  && lower right corner
  2131.     
  2132.         *-- inside of "border"
  2133.         nWidth2 = nWidth - 2
  2134.         nHeight2 = nHeight - 1
  2135.         @1,2 to 1,nWidth2 color &cHighColor.                 && horizontal top
  2136.         @1,2 to nHeight2,2 color &cHighColor.                && vertical left  
  2137.         @1,2 say chr(218) color &cHighColor.                 && upper left corner
  2138.         @nHeight2,2 say chr(192) color &cHighColor.          && lower left corner
  2139.         @1,nWidth2 to nHeight2,nWidth2 color &cShadColor.    && vertical right
  2140.         @nHeight2,3 to nHeight2,nWidth2 color &cShadColor.   && horizontal bottom
  2141.         @1,nWidth2 say chr(191) color &cShadColor.           && upper right corner
  2142.         @nHeight2,nWidth2 say chr(217) color &cShadColor.    && lower right corner
  2143.     
  2144.     endif
  2145.     
  2146.     *-- reset border
  2147.     set border to &cBorder.
  2148.  
  2149. RETURN
  2150. *-- EoP: Bord3D
  2151.  
  2152. PROCEDURE Bord3D2
  2153. *-------------------------------------------------------------------------------
  2154. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  2155. *-- Date........: 03/18/1993
  2156. *-- Notes.......: This variation on BORD3D was written to deal with items
  2157. *--               that are "filled", rather than windows, that have a 
  2158. *--               set edge. This one requires that the actual coordinates
  2159. *--               get passed to it.
  2160. *-- Written for.: dBASE IV, 1.5
  2161. *-- Rev. History: 03/18/1993 -- Original
  2162. *-- Calls.......: None
  2163. *-- Called by...: Any
  2164. *-- Usage.......: Do Bord3D2 with <nTop>,<nLeft>,<nBottom>,<nRight>,<cColor>,;
  2165. *--                               <nStyle>
  2166. *-- Example.....: Do Bord3d2 with 0,15,4,60,cColor,1
  2167. *-- Returns.....: None
  2168. *-- Parameters..: nTop    = top row
  2169. *--               nLeft   = Left column
  2170. *--               nBottom = Bottom Row
  2171. *--               nRight  = Right Column
  2172. *--               cColor  = Color of area being filled
  2173. *--               nStyle  = type of 3-d border (1 = Raised, 2 = Inset)
  2174. *-------------------------------------------------------------------------------
  2175.  
  2176.     parameters nTop,nLeft,nBottom,nRight,cColor,nStyle
  2177.  
  2178.     *-- deal with border ...
  2179.     *-- figure out colors
  2180.     cBackColor = backcolor(cColor)
  2181.     cHighColor = "W+/"+cBackColor
  2182.     cShadColor = "N/"+cBackColor
  2183.     
  2184.     *-- if style is 1, we do the commands for a 'raised' border
  2185.     *-- if style is 2, we do an 'inset' border
  2186.     if nStyle < 1 .or. nStyle > 2  && if not 1 or 2 ...
  2187.         nStyle = 1
  2188.     endif
  2189.     
  2190.     if nStyle = 1
  2191.         *-- RAISED Border
  2192.         *-- Outside of "border"
  2193.         @nTop,nLeft to nTop,nRight     color &cHighColor. && horizontal top
  2194.         @nTop,nLeft to nBottom,nLeft   color &cHighColor. && vertical left  
  2195.         @nTop,nLeft say chr(218)       color &cHighColor. && upper left corner
  2196.         @nBottom,nLeft say chr(192)    color &cHighColor. && lower left corner
  2197.         @nTop,nRight to nBottom,nRight color &cShadColor. && vertical right
  2198.         @nBottom,nLeft+1 to nBottom,nRight color &cShadColor. && horizontal bottom
  2199.         @nTop,nRight say chr(191)      color &cShadColor. && upper right corner
  2200.         @nBottom,nRight say chr(217)   color &cShadColor. && lower right corner
  2201.     
  2202.         *-- inside of "border"
  2203.         @nTop+1,nLeft+2 to nTop+1,nRight-2   color &cShadColor. && horizontal top
  2204.         @nTop+1,nLeft+2 to nBottom-1,nLeft+2 color &cShadColor. && vertical left  
  2205.         @nTop+1,nLeft+2 say chr(218)         color &cShadColor. && upper left corner
  2206.         @nBottom-1,nLeft+2 say chr(192)      color &cShadColor. && lower left corner
  2207.         @nTop+1,nRight-2 to nBottom-1,nRight-2 color &cHighColor. && vertical right
  2208.         @nBottom-1,nLeft+3 to nBottom-1,nRight-2 color &cHighColor. && horizontal bottom
  2209.         @nTop+1,nRight-2 say chr(191)        color &cHighColor. && upper right corner
  2210.         @nBottom-1,nRight-2 say chr(217)     color &cHighColor. && lower right corner
  2211.     
  2212.     else
  2213.         *-- RECESSED Border
  2214.         *-- Outside of "border"
  2215.         @nTop,nLeft to nTop,nRight     color &cShadColor. && horizontal top
  2216.         @nTop,nLeft to nBottom,nLeft   color &cShadColor. && vertical left  
  2217.         @nTop,nLeft say chr(218)       color &cShadColor. && upper left corner
  2218.         @nBottom,nLeft say chr(192)    color &cShadColor. && lower left corner
  2219.         @nTop,nRight to nBottom,nRight color &cHighColor. && vertical right
  2220.         @nBottom,nLeft+1 to nBottom,nRight color &cHighColor. && horizontal bottom
  2221.         @nTop,nRight say chr(191)      color &cHighColor. && upper right corner
  2222.         @nBottom,nRight say chr(217)   color &cHighColor. && lower right corner
  2223.     
  2224.         *-- inside of "border"
  2225.         @nTop+1,nLeft+2 to nTop+1,nRight-2   color &cHighColor. && horizontal top
  2226.         @nTop+1,nLeft+2 to nBottom-1,nLeft+2 color &cHighColor. && vertical left  
  2227.         @nTop+1,nLeft+2 say chr(218)         color &cHighColor. && upper left corner
  2228.         @nBottom-1,nLeft+2 say chr(192)      color &cHighColor. && lower left corner
  2229.         @nTop+1,nRight-2 to nBottom-1,nRight-2 color &cShadColor. && vertical right
  2230.         @nBottom-1,nLeft+3 to nBottom-1,nRight-2 color &cShadColor. && horizontal bottom
  2231.         @nTop+1,nRight-2 say chr(191)        color &cShadColor. && upper right corner
  2232.         @nBottom-1,nRight-2 say chr(217)     color &cShadColor. && lower right corner
  2233.     
  2234.     endif
  2235.     
  2236.     *-- reset border
  2237.     set border to &cBorder.
  2238.     
  2239. RETURN
  2240. *-- EoP: Bord3D2
  2241.  
  2242. FUNCTION BackColor
  2243. *-------------------------------------------------------------------------------
  2244. *-- Programmer..: Jay Parsons       CIS 70160,340
  2245. *-- Date........: 02/24/1993
  2246. *-- Notes       : Returns background part of color string.
  2247. *-- Written for.: dBASE IV, Version 1.5.
  2248. *-- Rev. History: 02/04/1993 -- Original Release
  2249. *-- Calls       : None
  2250. *-- Called by...: Any
  2251. *-- Usage.......: BackColor( <cColor> )
  2252. *-- Example.....: ? BackColor( "N/BG" )
  2253. *-- Parameters..: cColor    -   String holding color foreground and background
  2254. *-- Returns     : Character, string with background portion of the color.
  2255. *--               Returns empty string if no such portion.
  2256. *-------------------------------------------------------------------------------
  2257.         parameters cColor
  2258.         private cRet
  2259.         cRet = upper( trim( ltrim( cColor ) ) )
  2260.         if "/" $ cRet
  2261.           cRet = substr( cRet, at( "/", cRet ) + 1 )
  2262.           if "*" $ cRet
  2263.             cRet = stuff( cRet, at( "*", cRet ), 1, "" )
  2264.           endif
  2265.           if "+" $ cRet 
  2266.             cRet = stuff( cRet, at( "+", cRet ), 1, "" )
  2267.           endif
  2268.         else
  2269.           cRet = ""
  2270.         endif
  2271. RETURN upper( ltrim( trim( cRet ) ) )
  2272. *-- EoF: BackColor()
  2273.  
  2274. PROCEDURE WordWrap
  2275. *-------------------------------------------------------------------------------
  2276. *-- Programmer..: David Frankenbach (CIS: 72147,2635)
  2277. *-- Date........: 01/14/1993 (Version 1.1)
  2278. *-- Notes.......: Wraps a long string, breaking it into strings that have
  2279. *--               a maximum length of nWidth. The first output is displayed
  2280. *--               @nRow, nCol. Words are not split ...
  2281. *-- Written for.: dBASE IV, 1.5
  2282. *-- Rev. History: 01/06/1993 -- Original Release (Version 1.0)
  2283. *--               01/14/1993 -- Version 1.1 -- Corrected side-effect of 
  2284. *--                       destroying string arg, added test for 
  2285. *--                       string[nWidth+1] = " "
  2286. *-- Calls.......: None
  2287. *-- Called by...: Any
  2288. *-- Usage.......: do WordWrap with <nRow>, <nCol>, <cString>, <nWidth>
  2289. *-- Example.....: do WordWrap with 2,2,cText,38
  2290. *-- Returns.....: None
  2291. *-- Parameters..: nRow     = Row to display first line at
  2292. *--               nCol     = Left side of area to display text at
  2293. *--               cString  = text to wrap
  2294. *--               nWidth   = Width of area to wrap text in
  2295. *-------------------------------------------------------------------------------
  2296.  
  2297.     parameters nRow, nCol, cString, nWidth
  2298.     private cTemp, nI, cStr
  2299.     
  2300.     cStr = cString                  && work with a COPY of input, to avoid
  2301.                                     && destroying original
  2302.     
  2303.     do while len(cStr) > 0          && while there's something to work on
  2304.         if (nWidth < len(cStr))
  2305.             nI = nWidth               && look for last " " in first nWidth
  2306.             
  2307.             if substr(cStr,nI+1,1) # " "
  2308.                 do while ( (nI > 0) .and. (substr(cStr,nI,1) # " ") )
  2309.                     nI = nI - 1
  2310.                 enddo
  2311.             endif
  2312.             
  2313.             if nI = 0                 && no spaces
  2314.                 nI = nWidth            && get first nWidth characters
  2315.             endif
  2316.         else
  2317.             nI = len(cStr)         && use the rest of the string
  2318.         endif
  2319.         
  2320.         cTemp = left(cStr,nI)     && get the part we're going to display
  2321.         
  2322.         if nI < len(cStr)         && remove that part
  2323.            cStr = ltrim(substr(cStr,nI + 1))
  2324.         else
  2325.             cStr = ""
  2326.         endif
  2327.         
  2328.         *-- display it
  2329.         @nRow,nCol say cTemp
  2330.         *-- move to next row
  2331.         nRow = nRow + 1
  2332.         
  2333.     enddo
  2334.     
  2335. RETURN
  2336. *-- EoP: WordWrap
  2337.  
  2338. *===============================================================================
  2339. * COLOR PROCESSING -- These routines handle setting colors, dealing with
  2340. * checking how colors are set, and so on. Anything that's not here is in
  2341. * the library file:  COLOR.PRG.
  2342. *===============================================================================
  2343.  
  2344. PROCEDURE SetColor
  2345. *-------------------------------------------------------------------------------
  2346. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2347. *-- Date........: 07/24/1992
  2348. *-- Notes.......: This routine is designed set colors of the primary "areas"
  2349. *--               on the screen, based on a color memvar being passed to it.
  2350. *--               This color memvar should contain two sets of colors (normal
  2351. *--               and enhanced). See below for more details. 
  2352. *-- Written for.: dBASE IV, 1.5
  2353. *-- Rev. History: 07/24/1992 -- Original
  2354. *-- Calls.......: ColorBrk()           Function in PROC.PRG
  2355. *-- Called by...: Any
  2356. *-- Usage.......: do SetColor with <cColorVar>
  2357. *-- Example.....: cOldColor = set("ATTRIBUTES")  && save old colors
  2358. *--               do SetColor with cl_dialog
  2359. *--                 *-- do whatever needs to be done with these colors
  2360. *--               do ReColor with cOldColor      && restore old colors
  2361. *-- Returns.....: None
  2362. *-- Parameters..: cColorVar = Color memvar. This must contain a "normal"
  2363. *--                           color and a "highlight" color in the format:
  2364. *--                           <forg>/<back>,<forg>/<back>
  2365. *--                           i.e., "rg+/gb,w+/b"
  2366. *-------------------------------------------------------------------------------
  2367.  
  2368.     parameters cColorVar
  2369.     private cNormCol,cHighCol
  2370.     
  2371.     cNormCol = colorbrk(cColorVar,1)  && extract "normal" colors
  2372.     cHighCol = colorbrk(cColorVar,2)  && extract "highlight" colors
  2373.     
  2374.     set color of normal    to &cNormCol  && regular screen/text colors
  2375.     set color of messages  to &cNormCol  && messages/menu pads, etc.
  2376.     set color of box       to &cHighCol  && borders
  2377.     set color of fields    to &cHighCol  && data entry fields
  2378.     set color of highlight to &cHighCol  && highlighted items in menus, etc.
  2379.     
  2380. RETURN
  2381. *-- EoP: SetColor
  2382.  
  2383. PROCEDURE ReColor
  2384. *-------------------------------------------------------------------------------
  2385. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  2386. *-- Date........: 04/23/1992
  2387. *-- Notes.......: Restores colors to those held in a string of the form
  2388. *--               returned by set("ATTRIBUTE").
  2389. *-- Written for.: dBASE IV, Versions 1.0 - 1.5.
  2390. *-- Rev. History: 04/23/1992 -- Original
  2391. *-- Calls       : None
  2392. *-- Called by...: Any
  2393. *-- Usage.......: DO ReColor WITH <cColors>
  2394. *-- Example.....: DO Recolor WITH OldColors
  2395. *-- Parameters..: cColors, a string in the form returned by set("ATTRIBUTE").
  2396. *-- Side effects: Changes the screen colors.
  2397. *-------------------------------------------------------------------------------
  2398.  
  2399.   parameters cColors
  2400.   private cThis, cNext, nAt, cLeft, nX, cAreas
  2401.   cAreas = "   NORMHIGHBORDMESSTITLBOX INFOFIEL"
  2402.   cLeft = cColors + ", "
  2403.   nX = 0
  2404.   do while nX < 8
  2405.     nX = nX + 1
  2406.     cThis = substr( cAreas, 4 * nX, 4 )
  2407.     if nX = 3
  2408.       nAt = at( "&", cLeft )
  2409.       cNext = left( cLeft, nAt - 2 )
  2410.       cLeft = substr( cLeft, nAt + 3 )
  2411.       SET COLOR TO , , &cNext
  2412.     else
  2413.       nAt = at( ",", cLeft )
  2414.       cNext = left( cLeft, nAt - 1 )
  2415.       cLeft = substr( cLeft, nAt + 1 )
  2416.       SET COLOR OF &cThis TO &cNext
  2417.     endif
  2418.   enddo
  2419.  
  2420. RETURN
  2421. *-- EoP: ReColor
  2422.  
  2423. FUNCTION ColorBrk
  2424. *-------------------------------------------------------------------------------
  2425. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2426. *-- Date........: 03/24/1993
  2427. *-- Notes.......: This routine is designed to be used with any of my functions
  2428. *--               and procedures that accept a memory variable for color,
  2429. *--               and use a window. It's purpose is to break that color var
  2430. *--               into it's components (depending on which one the user wants)
  2431. *--               and return those components, so that they can then be used
  2432. *--               in SET COLOR OF ... commands.
  2433. *-- Written for.: dBASE IV, 1.1, 1.5 (written because of 1.5, but will work in
  2434. *--                1.1)
  2435. *-- Rev. History: 07/22/1992 - modified to handle memvars/color strings that
  2436. *--               may have only two parts to them (no <border>...), so that if
  2437. *--               the <nField> parm is 2, we get a valid value.
  2438. *--               03/24/1993 -- Lee Hite - Fixed to work correctly when 
  2439. *--               <cColorVar> contains a single colorset (i.e., "b/w").
  2440. *-- Calls.......: None
  2441. *-- Called by...: Any
  2442. *-- Usage.......: ColorBrk(<cColorVar>,<nField>)
  2443. *-- Example.....: set color of normal to ColorBrk(cColor,1)
  2444. *-- Returns.....: Either the field you asked for (1 thru 3) or null string ("").
  2445. *-- Parameters..: cColorVar = Color variable to extract data from
  2446. *--                   Assumes the form: <main color>,<highlight>,<border>
  2447. *--                   Where each part uses: <foreground>/<background> format
  2448. *--                    i.e., rg+/gb,w+/b,rg+/gb
  2449. *--               nField    = Field you want to extract
  2450. *-------------------------------------------------------------------------------
  2451.  
  2452.     parameters cColorVar, nField
  2453.     private cReturn, cExtracted
  2454.     
  2455.     do case
  2456.         case nField = 1
  2457.             if at(",",cColorVar) > 0
  2458.                 cReturn = left(cColorVar,at(",",cColorVar)-1)
  2459.             else
  2460.                 cReturn = cColorVar
  2461.             endif
  2462.         case nField = 2
  2463.             cExtract = substr(cColorVar,at(",",cColorVar)+1)  && everything to 
  2464.                                                                     && right of comma
  2465.             if at(",",cExtract) > 0
  2466.                 cReturn = left(cExtract,at(",",cExtract)-1)    && left of second ,
  2467.             else
  2468.                 cReturn = cExtract
  2469.             endif
  2470.         case nField = 3
  2471.             cExtract = substr(cColorVar,at(",",cColorVar)+1)
  2472.             if at(",",cExtract) > 0
  2473.                 cReturn = substr(cExtract,at(",",cExtract)+1)
  2474.             else
  2475.                 cReturn = ""
  2476.             endif
  2477.         otherwise
  2478.             cReturn = ""
  2479.     endcase
  2480.  
  2481. RETURN cReturn
  2482. *-- EoF: ColorBrk()
  2483.  
  2484. FUNCTION FBClrBrk
  2485. *------------------------------------------------------------------------------
  2486. *-- Programmer..: Joey D. Carroll (JOEY on USSBBS)
  2487. *-- Date........: 11/12/1992
  2488. *-- Notes.......: Extracts foreground/background colors from a string in the
  2489. *--                  form of a literal "n/gb" or of a variable.  It is useful
  2490. *--                  to use COLORBRK() to obtain this value.
  2491. *-- Written for.: dBASE IV, ver 1.5
  2492. *-- Rev. History: 11/12/1992 -- Original
  2493. *-- Calls.......: None
  2494. *-- Called by...: Any
  2495. *-- Usage.......: ?? FBClrBrk("B","w+/gr")
  2496. *-- Example.....: cNormalClr = "w+/gr"
  2497. *--               cForeClr   = FBClrBrk("F",cNormalClr)   && = "w+"
  2498. *--               cBackClr   = FBClrBrk("B",cNormalClr)   && = "gr"
  2499. *-- Returns.....: a sub-string of cColor
  2500. *-- Parameters..: cType  = "F" for foreground color  "B" for Background
  2501. *--               cColor = the color you want to extract from
  2502. *------------------------------------------------------------------------------
  2503.    parameters cType,cColor
  2504.    private cRetClr
  2505.    if upper(cType) = "F"
  2506.       cRetClr = iif(at("/",cColor) = 0,cColor,left(cColor,at("/",cColor)-1))
  2507.    else           && = "B"
  2508.       cRetClr = substr(cColor,at("/",cColor) + 1,2)
  2509.    endif
  2510.  
  2511. RETURN cRetClr
  2512. *-- EoF: FBClrBrk()
  2513.  
  2514. *===============================================================================
  2515. * STRING Manipulation. Most of these are in the library file:  STRINGS.PRG
  2516. * The ones here are common to a lot of apps and functions, and are here so
  2517. * that the library STRINGS.PRG need not be called.
  2518. *===============================================================================
  2519.  
  2520. FUNCTION AllTrim
  2521. *-------------------------------------------------------------------------------
  2522. *-- Programmer..: Phil Steele (from PCSDEMO.PRG -- Public Domain)
  2523. *-- Date........: 05/23/1991
  2524. *-- Notes.......: Complete trims edges of field (left and right)
  2525. *-- Written for.: dBASE IV, 1.1
  2526. *-- Rev. History: 05/23/1991 -- Original
  2527. *-- Calls.......: None
  2528. *-- Called by...: Any
  2529. *-- Usage.......: alltrim(<cString>)
  2530. *-- Example.....: ? alltrim("  Test String  ") 
  2531. *-- Returns.....: Trimmed string, i.e.:"Test String"
  2532. *-- Parameters..: cString = string to be trimmed
  2533. *-------------------------------------------------------------------------------
  2534.     
  2535.     parameters cString
  2536.     
  2537. RETURN ltrim(rtrim(cString))
  2538. *-- EoF: AllTrim()
  2539.  
  2540. FUNCTION Justify
  2541. *-------------------------------------------------------------------------------
  2542. *-- Programmer..: Roland Bouchereau (Ashton-Tate/Borland)
  2543. *-- Date........: 03/24/1993
  2544. *-- Notes.......: Used to pad a field/string on the right, left or both,
  2545. *--               justifying or centering it within the length specified.
  2546. *--               If the length of the string passed is greater than
  2547. *--               the size needed, the function will truncate it. 
  2548. *--               Taken from Technotes, June 1990. Defaults to Left Justify
  2549. *--               if invalid TYPE is passed ...
  2550. *-- Written for.: dBASE IV, 1.0
  2551. *-- Rev. History: Original function 06/15/1991
  2552. *--               12/17/1991 -- Modified into ONE function from three by
  2553. *--                  Ken Mayer, added a third parameter to handle that.
  2554. *--               12/23/1992 -- Modified by Joey Carroll to use STUFF()
  2555. *--                  instead of TRANSFORM().
  2556. *--               03/24/1993 -- Modified by Lee Hite, as the center
  2557. *--                  option wasn't working quite right ...
  2558. *-- Calls.......: None
  2559. *-- Called by...: Any
  2560. *-- Usage.......: Justify(<cFld>,<nLength>,"<cType>")
  2561. *-- Example.....: ?? Justify(Address,25,"R")
  2562. *-- Returns.....: Padded/truncated field
  2563. *-- Parameters..: cFld    =  Field/Memvar/Character String to justify
  2564. *--               nLength =  Width to justify within
  2565. *--               cType   =  Type of justification: L=Left, C=Center,R=Right
  2566. *-------------------------------------------------------------------------------
  2567.     
  2568.     parameters cFld,nLength,cType
  2569.     private cReturn
  2570.     
  2571.     cType = upper(cType)    && just making sure ...
  2572.     if type("cFld")+type("nLength")+type("cType") $ "CNC,CFC"
  2573.        *-- set a picture function of 'X's, with @I,@J or @B function
  2574.        cReturn = space(nLength)
  2575.         cReturn = stuff(cReturn,;
  2576.                 iif(cType = "C",((nLength-len(cFld))/2)+1,;
  2577.                 iif(cType = "R",nLength-len(cFld)+1,1)),;
  2578.                 len(cFld),cFld)
  2579.     else
  2580.         cReturn = ""
  2581.     endif
  2582.  
  2583. RETURN cReturn
  2584. *-- EoF: Justify()
  2585.  
  2586. FUNCTION State
  2587. *-------------------------------------------------------------------------------
  2588. *-- Programmer..: David G. Franknbach (FRNKNBCH)
  2589. *-- Date........: 04/22/1992
  2590. *-- Notes.......: Validation of state codes -- used to ensure that a user
  2591. *--               doing data entry will enter the proper codes. Added a few
  2592. *--               US Territory codes as well (Puerto Rico, etc.)
  2593. *-- Written for.: dBASE IV, 1.1
  2594. *-- Rev. History: 12/02/1991
  2595. *--               03/11/1992 -- Modified by Ken Mayer to handle
  2596. *--               the extra US Territories, and to ensure that the data is
  2597. *--               at least temporarily in upper case when doing the check ...
  2598. *--               04/22/1992 -- Modified by Jay Parsons to shorten
  2599. *--               (simplify) the routine by removing the cSTATE2 memvar.
  2600. *-- Calls.......: None
  2601. *-- Called by...: None
  2602. *-- Usage.......: STATE(<cState>)
  2603. *-- Example.....: @5,10 get cState valid required state(cState);
  2604. *--                     error chr(7)+"This is not a valid state code!"
  2605. *-- Returns.....: Logical (.t. if found, .f. otherwise)
  2606. *-- Parameters..: cState = state code to be checked ....
  2607. *-------------------------------------------------------------------------------
  2608.  
  2609.     parameters cState
  2610.     
  2611.     cStateList = "AL|AK|AZ|AR|CA|CO|CT|DE|DC|FL|GA|HI|ID|IL|IN|IA|KS|KY|LA|"+;
  2612.              "ME|MD|MA|MI|MN|MS|MO|MT|NE|NV|NH|NJ|NM|NY|NC|ND|OH|OK|OR|"+;
  2613.              "PA|RI|SC|SD|TN|TX|UT|VT|VA|WA|WV|WI|WY|PR|AS|GU|CM|TT|VI|"
  2614.     lOK = upper(cState) $ cStateList
  2615.  
  2616. RETURN lOK
  2617. *-- EoF: State()
  2618.  
  2619. *===============================================================================
  2620. *  DATE HANDLING ROUTINES -- Most of these are now in the library file: 
  2621. *  DATES.PRG (included with this version of PROC). However, a few are below,
  2622. *  as they have become 'standard' routines in many of my systems.
  2623. *===============================================================================
  2624.  
  2625. FUNCTION DateText
  2626. *-------------------------------------------------------------------------------
  2627. *-- Programmer..: Miriam Liskin
  2628. *-- Date........: 05/23/1991
  2629. *-- Notes.......: Display date in format Month, day year (e.g., July 1,1991)
  2630. *-- Written for.: dBASE IV, 1.1
  2631. *-- Rev. History: 05/23/1991 -- Original
  2632. *-- Calls.......: None
  2633. *-- Called by...: Any
  2634. *-- Usage.......: DateText(<dDate>) 
  2635. *-- Example.....: ? datetext(date())
  2636. *-- Returns.....: July 1, 1991
  2637. *-- Parameters..: dDate = date to be converted
  2638. *-------------------------------------------------------------------------------
  2639.  
  2640.     parameters dDate
  2641.     
  2642. RETURN CMONTH(dDate)+" "+ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  2643. *-- EoF: DateText()
  2644.  
  2645. FUNCTION DateText2
  2646. *-------------------------------------------------------------------------------
  2647. *-- Programmer..: Miriam Liskin
  2648. *-- Date........: 05/23/1991
  2649. *-- Notes.......: Display date in format day-of-week, Month day, year
  2650. *-- Written for.: dBASE IV, 1.1
  2651. *-- Rev. History: 05/23/1991 -- Original
  2652. *-- Calls.......: None
  2653. *-- Called by...: Any
  2654. *-- Usage.......: DateText2(<dDate>)
  2655. *-- Example.....: ? DateText2(date())
  2656. *-- Returns.....: Thursday, July 1, 1991
  2657. *-- Parameters..: dDate = date to be converted
  2658. *-------------------------------------------------------------------------------
  2659.  
  2660.     parameters dDate
  2661.     
  2662. RETURN CDOW(dDate)+", "+cmonth(dDate)+" "+;
  2663.        ltrim(str(day(dDate),2))+", "+str(year(dDate),4)
  2664. *-- EoF: DateText2()
  2665.  
  2666. FUNCTION Age
  2667. *-------------------------------------------------------------------------------
  2668. *-- Programmer..: Martin Leon (HMAN)
  2669. *-- Date........: 10/23/1991
  2670. *-- Notes.......: Returns age of person, given their birthdate as of DATE(),
  2671. *--               effectively, as of "Today".
  2672. *-- Written for.: dBASE IV, 1.1
  2673. *-- Rev. History: 10/23/1991 -- Original
  2674. *-- Calls.......: None
  2675. *-- Called by...: Any
  2676. *-- Usage.......: Age(<dBDay>)
  2677. *-- Example.....: ? "Joe is "+ltrim(str(age(dBDay)))+" today ..."
  2678. *-- Returns.....: Numeric value in years
  2679. *-- Parameters..: dBDay = birthdate of person attempting to find age of.
  2680. *-------------------------------------------------------------------------------
  2681.  
  2682.     parameters dBDay
  2683.     private dToday,nYears
  2684.     
  2685.     dToday = date()
  2686.     nYears = year(dToday) - year(dBDay)
  2687.     do case
  2688.         case month(dBDay) > month(dToday)
  2689.             nYears = nYears - 1
  2690.         case month(dBDay) = month(dToday)
  2691.             if day(dBDay) > day(dToday)
  2692.                 nYears = nYears - 1
  2693.             endif
  2694.     endcase
  2695.  
  2696. RETURN nYears
  2697. *-- EoF: Age()
  2698.  
  2699. *===============================================================================
  2700. * MISC ROUTINES -- Ones that don't fit into other categories, quite ... but
  2701. * are none-the-less very useful ... many of these routines have been placed
  2702. * in the library file:  MISC.PRG.
  2703. *===============================================================================
  2704.  
  2705. PROCEDURE SetPrint
  2706. *-------------------------------------------------------------------------------
  2707. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2708. *-- Date........: 05/24/1991
  2709. *-- Notes.......: Used to set the the appropriate default settings. 
  2710. *--               (Can be modified easily for other printers ...)
  2711. *--               If you want "letter quality" print on some printers,
  2712. *--               you can take the * out from the one line below. Note
  2713. *--               that some printer drivers don't have a "letter quality" mode,
  2714. *--               and dBASE will spit out an error message if you try to
  2715. *--               force it (by using _pquality). I use this routine for
  2716. *--               various systems, and only use _pquality for my dot matrix
  2717. *--               at home. Change the printer driver below to the one you
  2718. *--               are using. The _pdriver line only REALLY needs to be 
  2719. *--               in use on a LAN, where who knows what settings may have been
  2720. *--               dumped into the printer in between the time you loaded dBASE
  2721. *--               (and the printer driver) and the time you really want to
  2722. *--               print?
  2723. *-- Written for.: dBASE IV, 1.1
  2724. *-- Rev. History: 05/24/1991 -- Original
  2725. *-- Calls.......: None
  2726. *-- Called by...: Any
  2727. *-- Usage.......: do setprint
  2728. *-- Example.....: do setprint
  2729. *-- Returns.....: None
  2730. *-- Parameters..: None
  2731. *-------------------------------------------------------------------------------
  2732.     *_pdriver  = "HPLAS2I"  && printer driver
  2733.     _ppitch   = "PICA"     && printer pitch (10 CPI)        
  2734.     _box      = .t.           && make sure we can print boxes/line draw
  2735.     _ploffset = 0          && page offset (left side) to 0
  2736.     _lmargin  = 0          && left margin (also set to 0)
  2737.     _rmargin  = 80         && right margin set to 80
  2738.     _plength  = 66         && page length 
  2739.     _peject   = "NONE"     && don't send extra blank pages . . .
  2740.     * _pquality = .t.        && set print quality to high -- not available
  2741.                  && for some printers (i.e., LaserJets)
  2742.     
  2743. RETURN   
  2744. *-- EoP: SetPrint
  2745.  
  2746. FUNCTION DosRun
  2747. *-------------------------------------------------------------------------------
  2748. *-- Programmer..: Michael P. Dean (Ashton-Tate)
  2749. *-- Date........: 05/01/1992
  2750. *-- Notes.......: A routine to run a DOS program, checks to see if a
  2751. *--               window is active -- if so, it avoids the inevitable
  2752. *--               "Press any key to continue" and the subsequent messing
  2753. *--               up of the screen display.
  2754. *-- Written for.: dBASE IV, 1.1
  2755. *-- Rev. History: Pulled from A-T BBS 
  2756. *--               05/13/1991 - modified by Ken Mayer to use the DBASE
  2757. *--               RUN() function, rather than the ! or RUN commands.
  2758. *--               (suggested by Clinton L. Warren (VBCES).)
  2759. *--               Minor additions for screens from "Bosephus" on ATBBS 10/31/91
  2760. *--               12/14/1991 - modified by Jim Magnant (TXAGGIE) to deactivate
  2761. *--               and reactivate up to 10 windows ...
  2762. *--               04/21/1992 -- Modified for dBASE IV, 1.5 to use memory 
  2763. *--               handling parameters (.t.,<command>,.t.) of RUN() function.
  2764. *--               05/01/1992 -- Modified to allow use with EITHER 1.1 or 1.5.
  2765. *--                By calling VERSION() without a parm, the version of dBASE
  2766. *--                or RUNTIME is the last three characters on the right. 
  2767. *--                Taking the VAL() of that, we can ask if the version is => 1.5
  2768. *--                and process from there.
  2769. *-- Calls.......: None
  2770. *-- Called by...: Any
  2771. *-- Usage.......: DosRun(<cCmd>)
  2772. *-- Example.....: ndummy = dosrun("DIR /W /P")
  2773. *--                 * or
  2774. *--               ndummy = dosrun(memvar)  && where memvar contains dos
  2775. *--                                        && command and parameters ...
  2776. *-- Returns.....: Nul
  2777. *-- Parameters..: cCmd = Command (and parameters) to be executed
  2778. *-------------------------------------------------------------------------------
  2779.  
  2780.     parameter cCmd
  2781.     private aWindow, n, nRun
  2782.     
  2783.     save screen to sDOS          && save screen ...
  2784.     n = 0                        && set to 0 in case there are NO Windows active
  2785.     declare aWindow[10]
  2786.     aWindow[1] = window()               && grab window name of current window
  2787.     if len(trim(aWindow[1])) > 0        && if there's a window, deactivate
  2788.         n = 1 
  2789.         do while len(trim(aWindow[n])) > 0  && if there are more windows ...
  2790.             deactivate window &aWindow[n]    && deactivate them, too ...
  2791.             n = n + 1
  2792.             aWindow[n] = window()
  2793.         enddo
  2794.     endif
  2795.     set console off                     && don't display to screen
  2796.     if val(right(version(),3)) => 1.5   && check version number. If > 1.5
  2797.         nRun = run(.t.,"&cCmd",.t.)      &&  use complete swapping of dBASE, etc.
  2798.     else                                && else it's 1.1 or 1.0
  2799.         nRun = run("&cCmd")              &&  use older version of RUN() function
  2800.     endif
  2801.     set console on                      && ok, display to screen
  2802.     n = n - 1                           && compensate for final n=n+1 in prev.
  2803.     if len(trim(aWindow[1])) > 1        && if there's a window, reactivate
  2804.        do while n > 0                   && all but last window
  2805.             activate window &aWindow[n]   && activate
  2806.             n = n - 1                     && decrement stack
  2807.         enddo
  2808.         activate window &aWindow[1]      && activate final window ...
  2809.     endif
  2810.     restore screen from sDOS
  2811.     release screen sDOS
  2812.     
  2813. RETURN ""
  2814. *-- EoF: DosRun()
  2815.  
  2816. FUNCTION ScrnRpt
  2817. *-------------------------------------------------------------------------------
  2818. *-- Programmer..: Bryan Flynn (AT/BOR-BBS)
  2819. *-- Date........: 10/31/1991
  2820. *-- Notes.......: Used to display a dBASE Report on screen, allowing pauses
  2821. *--               when the screen is full.
  2822. *-- Written for.: dBASE IV, 1.1
  2823. *-- Rev. History: Changed by a lot of people to current version.
  2824. *-- Calls.......: None
  2825. *-- Called by...: Any
  2826. *-- Usage.......: ?ScrnRpt("<cRpt cArg>")
  2827. *-- Example.....: ?ScrnRpt("FT_REP1 FOR PROB='HPEQUIP'")
  2828. *-- Returns.....: ""  (Nul)
  2829. *-- Parameters..: cRpt  = Name of report with any arguments for command line
  2830. *-------------------------------------------------------------------------------
  2831.  
  2832.     Parameter cRpt
  2833.     private lPWait, nPLength, cEscape
  2834.     
  2835.     *-- save system variables
  2836.    lPWait   = _pwait
  2837.    nPLength = _plength
  2838.     cEscape  = SET("ESCAPE")
  2839.     *-- set new variables
  2840.    _pwait   = .t.
  2841.     _plength = iif("43" $ SET("DISPLAY"),40,25)  && if EGA43, set to 40, else 25
  2842.    set escape on
  2843.     
  2844.     *-- store current screen
  2845.    save screen to sTemp
  2846.    clear
  2847.  
  2848.     *-- set printer to nowhere and generate report
  2849.    set printer to nul
  2850.    report form &cRpt noeject to print
  2851.  
  2852.     *-- set things back to normal
  2853.    set escape &cEscape
  2854.    set printer to LPT1
  2855.    wait
  2856.    clear
  2857.    restore screen from sTemp
  2858.    release screen sTemp
  2859.    _pwait   = lPWait
  2860.    _plength = nPLength
  2861.  
  2862. RETURN ""
  2863. *-- EoF: ScrnRpt()
  2864.  
  2865. PROCEDURE SetMouse
  2866. *-------------------------------------------------------------------------------
  2867. *-- Programmer..: Kenneth J. Mayer (CIS: 71333,1030)
  2868. *-- Date........: 03/11/1993
  2869. *-- Notes.......: Allows user to toggle mouse on/off.
  2870. *-- Written for.: dBASE IV, 2.0
  2871. *-- Rev. History: 03/11/1993 -- Original
  2872. *-- Calls.......: None
  2873. *-- Called by...: Any
  2874. *-- Usage.......: Do SetMouse 
  2875. *-- Example.....: c_Mouse = "ON"
  2876. *--               on key label alt-m do setmouse 
  2877. *-- Returns.....: None
  2878. *-- Parameters..: c_Mouse = 'current' status of mouse -- this is a public
  2879. *--                         memvar, and should be defined as such. This
  2880. *--                         routine will change the status of said memvar
  2881. *--                         if it exists, or return if it does not.
  2882. *--                    c_Mouse is not _really_ a parameter ... however ...
  2883. *-------------------------------------------------------------------------------
  2884.  
  2885.     if type("C_MOUSE") = "L" .or. type("C_MOUSE") = "U"
  2886.         RETURN
  2887.     endif
  2888.  
  2889.     if upper(c_Mouse) = "ON"
  2890.         set mouse off
  2891.         c_Mouse = "OFF"
  2892.     else
  2893.         set mouse on
  2894.         c_Mouse = "ON"
  2895.     endif
  2896.     
  2897. RETURN
  2898. *-- EoP: SetMouse
  2899.  
  2900. FUNCTION SwitchLib
  2901. *-------------------------------------------------------------------------------
  2902. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  2903. *-- Date........: 05/01/1992
  2904. *-- Notes.......: Used with dBASE IV, 1.5 to switch LIBRARY files. It's designed
  2905. *--               as a quick toggle between libraries. See example below.
  2906. *-- Written for.: dBASE IV, 1.5
  2907. *-- Rev. History: 05/01/1992 -- Original
  2908. *-- Calls.......: None
  2909. *-- Called by...: Any
  2910. *-- Usage.......: SwitchLib(<cNewLib>)
  2911. *-- Example.....: cOldLib = SwitchLib("FILES")
  2912. *--               *-- execute function/procedure needed
  2913. *--               cOldLib = SwitchLib("&cOldLib")
  2914. *-- Returns.....: Old Library setting
  2915. *-- Parameters..: cNewLib = Library file you wish to change to. If the file
  2916. *--                         extension is not '.PRG', you should add the file
  2917. *--                         extension to the description (I.e, "FILES.LIB")
  2918. *-------------------------------------------------------------------------------
  2919.     
  2920.     parameters cNewLib
  2921.     private cCurLib
  2922.     
  2923.     cCurLib = set("LIBRARY")
  2924.     set library to &cNewLib.
  2925.     
  2926. RETURN cCurLib
  2927. *-- EoF: SwitchLib()
  2928.  
  2929. FUNCTION VerLevel
  2930. *-------------------------------------------------------------------------------
  2931. *-- Programmer..: Bowen Moursund (CIS: 76566,1405)
  2932. *-- Date........: 06/24/1992
  2933. *-- Notes.......: Returns the numeric version number of the current version
  2934. *--               of dBASE or RUNTIME. Useful in version specific routines.
  2935. *-- Written for.: dBASE IV, 1.5
  2936. *-- Rev. History: 06/24/1992 -- Original
  2937. *-- Calls.......: None
  2938. *-- Called by...: Any
  2939. *-- Usage.......: VerLevel()
  2940. *-- Example.....: if VerLevel() >= 1.5
  2941. *-- Returns.....: a numeric equivalent of Version()
  2942. *-- Parameters..: None
  2943. *-------------------------------------------------------------------------------
  2944.  
  2945.     private cVersion, nPos
  2946.     cVersion = version()
  2947.     nPos = 1
  2948.     do while left(right(cVersion,nPos),1) # " "
  2949.     nPos = nPos + 1
  2950.     enddo
  2951.  
  2952. RETURN val(right(cVersion,nPos+1))
  2953. *-- Eof() VerLevel
  2954.  
  2955. *===============================================================================
  2956. *-- End of Procedure File -- PROC.PRG
  2957. *===============================================================================
  2958.