home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / DATABASE / PROC.ZIP / PROC2.PRG
Text File  |  1991-03-04  |  17KB  |  571 lines
  1. **********************************************************************
  2. *-- Name.......: PROC.PRG
  3. *-- Programmer.: Kenneth J. Mayer, SofTech, Inc.
  4. *-- Date.......: 3/4/90
  5. *-- Version....: dBASE IV, 1.1
  6. *-- Notes......: This is a generic procedure file. 
  7. *                Sources: Rick Price (Hammett on ATBBS)
  8. *                         Liskin's dBASE IV Programming Book 
  9. *                                      (Miriam Liskin)
  10. *                         Ashton-Tate (ShadowG)
  11. *********************************************************************
  12. *-- Note that to use this program file, the program must have the line
  13. *-- in it stating   SET PROCEDURE TO PROC  (usually early in the prog.)
  14. *-- When done, it is a good idea to close the procedure file, using the
  15. *-- command         SET PROCEDURE TO
  16. *=====================================================================
  17. *
  18. * open_screen    Used to give a texture to the background of the screen.
  19. *                    USAGE:  do open_screen
  20. *
  21. * do_wait        Used in place of the standard WAIT command, deals with
  22. *                    centering the text at the message line (row 24).
  23. *              USAGE:  lf_wait = do_wait("message")  
  24. *                            OR
  25. *                      lf_wait = do_wait("")  && default message
  26. *
  27. * jazclear        Used to clear the screen from the middle out -- fancy clear
  28. *                    could be used with open_screen, to really fancify things!
  29. *                    USAGE:  do jazclear
  30. *
  31. * center            Centers text on the screen with @says
  32. *                    USAGE:   DO CENTER with row,screenwidth,"color(s),"message"
  33. *              EXAMPLE: DO CENTER WITH 5,80,"rg+/r",". . . PRINTING . . ."
  34. *
  35. * surround        Displays a message surrounded by a box anywhere on the screen
  36. *                    USAGE:  DO SURROUND WITH row,column,"colors","text"
  37. *
  38. * message        Displays a message, centered, pauses until user presses a key
  39. *                    USAGE:  DO MESSAGE WITH row,screenwidth,"colors","text"
  40. *
  41. * message2        Displays a message in a window, pauses for user to press key
  42. *                    USAGE:  DO MESSAGE2 WITH "Text"
  43. *
  44. * message3        Displays a message in a window, pauses for user, will wrap a
  45. *                    long message inside the window.
  46. *                    USAGE:  DO MESSAGE3 WITH "text"
  47. *
  48. * message4        Displays a 2-line message in a predefined window and pauses
  49. *                    USAGE:  DO MESSAGE4 WITH "text1","text2"
  50. *
  51. * monitor        Displays a status message to monitor a long-running operation
  52. *                    that operates on multiple records . . . 
  53. *                    USAGE:  DO MONITOR WITH "text"
  54. *                              DO WHILE  (or SCAN)
  55. *                         stuff -- process records
  56. *                         @4,x DISPLAY ltrim(str(recno())) && current record
  57. *                                                     && in window MONITOR
  58. *                      ENDDO  (endscan)
  59. *                      DEACTIVATE WINDOW MONITOR
  60. *                               RELEASE WINDOW MONITOR
  61. *
  62. * scrnhead        Displays a heading on the screen in a box 2 spaces wider than
  63. *                    the text, with a custom border (double line top, single the
  64. *                    rest)
  65. *                    USAGE: DO SCRNHEAD WITH "colors","Text"
  66. *
  67. * yesno            Asks a yes/no question in a dialog window/box
  68. *                    USAGE: ll_yesno = .t.  && or .f. depending on what is needed
  69. *                                                  && returns .t. or .f. from procedure
  70. *                                                  && value here is default for procedure
  71. *                             DO YESNO WITH LL_YESNO,"Message"
  72. *                             if ll_yesno    && do some stuff
  73. *
  74. * yes                These two procedures are a part of the yesno procedure above.
  75. * no
  76. *
  77. * datetext        Display date in format Month, day year (eg July 1, 1991)
  78. *                    USAGE:  DATETEXT(datefield)
  79. *
  80. * datetxt2        Display date in format dayofweek, month day, year
  81. *                                                (eg Monday, July 1, 1991)
  82. *                    USAGE:  DATETXT2(datefield)
  83. *
  84. * zipok            checks valid zipcode (US) or postal code (other)
  85. *                    USAGE:  ZIPOK(zipfield)
  86. *
  87. * isunique        Checks a keyfield to see if it is a unique entry
  88. *                    USAGE:  USE database ORDER tag ALIAS aliasname
  89. *                      USE database ORDER tag ALIAS DupCheck AGAIN
  90. *                                * second use of database is read only for ISUNIQUE
  91. *                               @x,y SAY "prompt" GET mvar PICTURE "picture";
  92. *                                    valid required ISUNIQUE(mvar);
  93. *                                    message "Enter a UNIQUE code";
  94. *                                    error chr(7)+"Field must be unique!"
  95. *                        where 'mvar' is memory variable/field being checked against
  96. *                        a specific 'field'. Make sure the correct index is set
  97. *                        as this function uses the SEEK command.
  98. *                        ALSO modify the field in the function below.
  99. *
  100. * shadowg      Creates a shadow for a window (taken from the dBASE IV
  101. *               picklist commands)
  102. *              USAGE:  SAVE SCREEN TO temp
  103. *                              DEFINE WINDOW name FROM trow,tcol TO brow,bcol DOUBLE
  104. *                              DO shadowg WITH trow,tcol,brow,bcol
  105. *                              ACTIVATE WINDOW name
  106. *                                perform actions in window
  107. *                              DEACTIVATE WINDOW name
  108. *                              RESTORE SCREEN FROM temp
  109. *=====================================================================
  110.  
  111. PROCEDURE open_screen
  112.  
  113.     ** Designed to give fancy opening screen -- written by Rick Price
  114.     ** stolen agregiously by Ken Mayer (with Rick's permission)
  115.     
  116.     clear
  117.     x=0
  118.     lc_Backdrp = chr(176)  && chr(176) = "░"
  119.     do while x<3
  120.        @x,0 to x+3,79 lc_Backdrp        && display this box
  121.        sx=x
  122.        x=x+6
  123.        @x,0 to x+3,79 lc_Backdrp
  124.        x=x+6
  125.        @x,0 to x+3,79 lc_Backdrp
  126.        x=x+6
  127.        @x,0 to x+3,79 lc_Backdrp
  128.        x = sx+1
  129.     enddo
  130.     @24,0 to 24,79 lc_Backdrp
  131.  
  132. RETURN    && end of procedure open_screen
  133.  
  134. *---------------------------------------------------------------------
  135.  
  136. FUNCTION Do_Wait
  137.  
  138.     ** Another routine stolen from Rick Price to handle the need for
  139.     ** a wait, but killing the ESCAPE key, amongst other things.
  140.     
  141.     parameters lc_Message
  142.  
  143.     lc_WaitCur = SET("CURSOR")    && save status of cursor
  144.     SET CURSOR OFF
  145.     
  146.     ** The the passed parameter (message_to_display) is null, use a generic
  147.     ** message.
  148.     lc_Message = ;
  149.     iif(""=lc_Message," Press any key to continue . . . ",lc_Message)
  150.     * deal with centering/truncating message
  151.     ln_MesLen = LEN(lc_Message)
  152.     lc_Message = iif(ln_MesLen>80,LEFT(lc_Message,80),lc_Message)
  153.     ln_MesLen = LEN(lc_Message)  && reset if message was longer than 80
  154.     @24,INT((80-ln_MesLen)/2) say lc_Message COLOR r/w
  155.     lc_RetStr=CHR(Inkey(0))
  156.     set cursor &lc_waitcur
  157.  
  158. RETURN lc_RetStr  && end of routine  Do_Wait
  159.  
  160. *---------------------------------------------------------------------
  161.  
  162. PROCEDURE JazClear
  163.  
  164.     ** also stolen from Rick Price -- another fancy screen clear
  165.     ** explode outward from the center -- pretty fancy stuff
  166.     
  167.     ln_WinR1 = 0    && row 1
  168.     ln_WinR2 = 24  && row 2
  169.     ln_WinC1 = 0   && column 1
  170.     ln_WinC2 = 79  && column 2
  171.     ln_Step = 1    && amount to increment by
  172.     mn_WinC1 = INT((ln_WinC2-ln_WinC1)/2)+ln_WinC1
  173.     mn_WinC2 = mn_WinC1+1
  174.     mn_WinR1 = INT((ln_WinR2-ln_WinR1)/2)+ln_WinR1
  175.     mn_WinR2 = mn_WinR1+1
  176.     
  177.     ** Adjust step offset values: ln_ColOff & ln_RowOff
  178.     ** Vertical steps - mn_WinR1-ln_WinR1
  179.     ln_TmpAdjR = int((ln_WinR2 - ln_WinR1)/2)
  180.     ln_TmpAdjC = int((ln_WinC2 - ln_WinC1)/2)
  181.     
  182.     ln_AdjRow = ;
  183.     iif(ln_TmpAdjC > ln_TmpAdjR, ln_TmpAdjR/ln_TmpAdjC,1) * ln_Step
  184.     
  185.     ln_AdjCol = ;
  186.     iif(ln_TmpAdjR > ln_TmpAdjC, ln_TmpAdjC/ln_TmpAdjR,1) * ln_Step
  187.     
  188.     ln_colleft = ln_WinC1
  189.     ln_colrite = ln_WinC2
  190.     ln_RowTop = ln_WinR1
  191.     ln_RowBot = ln_WinR2
  192.     ln_WinC1 = mn_WinC1
  193.     ln_WinC2 = mn_WinC2
  194.     ln_WinR1 = mn_WinR1
  195.     ln_WinR2 = mn_WinR2
  196.     DO WHILE (ln_WinC1#ln_ColLeft .or. ln_WinC2#ln_ColRite .or. ;
  197.         ln_WinR1 # ln_RowTop .or. ln_WinR2 # ln_RowBot)
  198.         
  199.         * Adjust coordinates for the clear (moving out from the middle)
  200.         ln_WinR1 = ;
  201.         ln_WinR1-IIF(ln_RowTop<ln_WinR1-ln_AdjRow,ln_AdjRow,ln_WinR1-ln_RowTop)
  202.         ln_WinR2 = ;
  203.         ln_WinR2+IIF(ln_RowBot>ln_WinR2+ln_AdjRow,ln_AdjRow,ln_RowBot-ln_WinR2)
  204.         ln_WinC1 = ;
  205.         ln_WinC1-IIF(ln_ColLeft<ln_WinC1-ln_AdjCol,ln_AdjCol,ln_WinC1-ln_ColLeft)
  206.         ln_WinC2 = ;
  207.         ln_WinC2+IIF(ln_ColRite>ln_WinC2+ln_AdjCol,ln_AdjCol,ln_ColRite-ln_WinC2)
  208.         
  209.         * Perform the clear
  210.         @ln_WinR1,ln_WinC1 CLEAR TO ln_WinR2,ln_WinC2
  211.         @ln_WinR1,ln_WinC1 TO ln_WinR2,ln_WinC2
  212.     ENDDO
  213.     CLEAR
  214. RETURN   && from JazClear
  215.  
  216. *---------------------------------------------------------------------
  217.  
  218. PROCEDURE center
  219.     ** Used to center text on the screen with @SAYs, stolen from Miriam
  220.     ** Liskin's dBASE IV Programming Book
  221.     
  222.     PARAMETERS mline,mwidth,mcolor,mtext
  223.     
  224.     mtext = trim(mtext)
  225.     mcol = (mwidth-len(mtext))/2
  226.     @mline,mcol say mtext color &mcolor.
  227.     
  228. RETURN   && from procedure center
  229.  
  230. *---------------------------------------------------------------------
  231.  
  232. PROCEDURE Surround
  233.  
  234.     ** from Miriam Liskin's Book
  235.     ** Displays text surrounded by a box anywhere on the screen
  236.     
  237.     parameters mline,mcolumn,mcolor,mtext
  238.     
  239.     mtext = " " + TRIM(mtext) + " "    && add spaces around text
  240.     @mline-1,mcolumn-1 to mline+1,mcolumn+LEN(mtext) DOUBLE;
  241.         color &mcolor.
  242.     @mline,mcolumn SAY mtext COLOR W+/B  && bright white on blue
  243.     
  244. RETURN  && from procedure Surround
  245.  
  246. *---------------------------------------------------------------------
  247.  
  248. PROCEDURE Message
  249.  
  250.     ** from Miriam Liskin's Book
  251.     ** Displays a centered message and pauses until user presses a key
  252.     ** uses CENTER above
  253.     
  254.     parameters mline,mwidth,mcolor,mtext
  255.     
  256.     @mline,0
  257.     do center WITH mline,mwidth,mcolor,mtext
  258.     wait ""
  259.     @mline,0
  260.  
  261. RETURN  && from procedure Message
  262.  
  263. *---------------------------------------------------------------------
  264.  
  265. PROCEDURE Message2
  266.  
  267.     ** from Miriam Liskin's Book
  268.     ** Displays a message in a window and pauses until user presses a key
  269.     
  270.     parameters mtext
  271.     
  272.     DEFINE Window Message FROM 10,10 to 14,70 DOUBLE
  273.     ACTIVATE Window Message
  274.     
  275.     Do Center WITH 1,60,"W+/B",mtext
  276.     wait
  277.     
  278.     Deactivate Window Message
  279.     Release Window Message
  280.  
  281. RETURN  && from Message2
  282.  
  283. *---------------------------------------------------------------------
  284.  
  285. PROCEDURE message3
  286.  
  287.     ** From Miriam Liskin's Book
  288.     ** displays message in a window and pauses until user presses a key
  289.     
  290.     Parameters mtext
  291.     
  292.     mlines = Int(len(mtext) / 38) + 5    && set # of lines for window
  293.     
  294.     DEFINE WINDOW message FROM 8,20 to 8+mlines,60 DOUBLE
  295.     ACTIVATE WINDOW MESSAGE
  296.     
  297.     mlmargin = _lmargin
  298.     mrmargin = _rmargin
  299.     malignment = _alignment
  300.     mwrap = _wrap
  301.     
  302.     _lmargin = 1 
  303.     _rmargin = 38
  304.     _alignment = "CENTER"
  305.     _wrap = .t.
  306.     
  307.     ?mtext
  308.     ?
  309.     WAIT "    Press any key to continue . . ."
  310.     
  311.     _lmargin = mlmargin
  312.     _rmargin = mrmargin
  313.     _alignment = malignment
  314.     _wrap = mwrap
  315.     
  316.     deactivate window message
  317.     release window message
  318.  
  319. RETURN    && from procedure Message3
  320.  
  321. *---------------------------------------------------------------------
  322.  
  323. PROCEDURE message4
  324.  
  325.     ** from Miriam Liskin's Book
  326.     ** Display a message in a predefined window and pause
  327.     
  328.     parameters mtext1,mtext2
  329.     
  330.     define window MONITOR from 10,10 to 18,70 double
  331.     activate window MONITOR
  332.     
  333.     mlmargin = _lmargin
  334.     mrmargin = _rmargin
  335.     mwrap = _wrap
  336.  
  337.     _lmargin = 1 
  338.     _rmargin = 58
  339.     _wrap = .t.
  340.     
  341.     ?  mtext1
  342.     ?  mtext2
  343.     ?
  344.     wait "   Press any key to continue . . ."
  345.  
  346.     _lmargin = mlmargin
  347.     _rmargin = mrmargin
  348.     _wrap = mwrap
  349.     
  350.     deactivate window MONITOR
  351.     release window MONITOR
  352.     
  353. RETURN    && from procedure MESSAGE4
  354.  
  355. *---------------------------------------------------------------------
  356.  
  357. PROCEDURE monitor
  358.  
  359.     ** taken from Miriam Liskin's Book
  360.     ** display a status message to monitor a long-running operation
  361.     ** user must specify in processing the record# to place in the
  362.     ** box on line 4 . . . Must also deactivate window MONITOR and
  363.     ** release it from MEMORY
  364.     
  365.     parameters mtext
  366.     
  367.     define window MONITOR From 10,10 to 18,70 DOUBLE
  368.     activate window monitor
  369.     
  370.     do center with 1,60,"",mtext
  371.     do center with 2,60,"","Please do not interrupt"
  372.     @4,10 say "Working on record          of" + ltrim(str(reccount(),5))
  373.     
  374. RETURN    && from procedure MONITOR
  375.  
  376. *---------------------------------------------------------------------
  377.  
  378. PROCEDURE scrnhead
  379.  
  380.     ** taken from Miriam Liskin's Book
  381.     ** Display a heading in a box 2 spaces wider than text with
  382.     ** custom border (double line top, single line sides)
  383.     
  384.     parameters mcolor,mtext
  385.     
  386.     mtext = " "+TRIM(mtext)+" "
  387.     mtextstart = (80-len(trim(mtext)))/2
  388.     @1,mtextstart-1 to 3,81-mtextstart 205,196,179,179,213,184,192,217;
  389.         color &mcolor.
  390.     @2, mtextstart say mtext color w+/b    && bright white on blue
  391.  
  392. RETURN    && from procedure scrnhead
  393.  
  394. *---------------------------------------------------------------------
  395.  
  396. PROCEDURE Yesno
  397.  
  398.     ** from Miriam Liskin's Book
  399.     ** asks a Yes-No question in a dialog box!
  400.     
  401.     parameter manswer,mquestion
  402.     
  403.     DEFINE Window yesno FROM 8,20 to 15,60 double
  404.     
  405.     define menu yesno
  406.     define pad yes of yesno Prompt "Yes" at 4,10
  407.     define pad no  of yesno Prompt "No"  at 4,25
  408.     On Selection Pad Yes of yesno Do Yes    && defined below
  409.     On Selection pad No  of yesno Do No        && defined below
  410.     
  411.     ACTIVATE Window yesno
  412.     mlmargin = _lmargin    && store system values
  413.     mrmargin = _rmargin
  414.     mwrap    = _wrap
  415.     _lmargin = 2            && set local values
  416.     _rmargin = 38
  417.     _wrap    = .t.
  418.     
  419.     ?mquestion
  420.     ?
  421.     if manswer
  422.         ACTIVATE MENU yesno PAD Yes
  423.     else
  424.         ACTIVATE MENU yesno PAD No
  425.     endif
  426.     
  427.     _lmargin = mlmargin    && reset system values
  428.     _rmargin = mrmargin
  429.     _wrap    = mwrap
  430.     
  431.     Deactivate Window yesno
  432.     release window yesno
  433.     release menu yesno
  434.  
  435. RETURN    && from procedure Yesno
  436.  
  437. PROCEDURE Yes
  438.     manswer = .t.
  439.     Deactivate Menu
  440. RETURN
  441.  
  442. PROCEDURE No
  443.     manswer = .f.
  444.     Deactivate Menu
  445. RETURN
  446.  
  447. *---------------------------------------------------------------------
  448.  
  449. FUNCTION Datetext
  450.  
  451.     ** stolen from Miriam Liskin's book
  452.     ** displays date in text format (e.g., July 1, 1991)
  453.     
  454.     parameters mdate
  455.     
  456. RETURN CMONTH(mdate)+" "+ltrim(str(day(mdate),2))+", "+;
  457.         str(year(mdate),4)
  458.  
  459. *---------------------------------------------------------------------
  460.  
  461. FUNCTION datetxt2
  462.  
  463.     ** from Miriam Liskin's book
  464.     ** displays date in text format (e.g., Monday, July 1, 1991)
  465.     
  466.     parameters mdate
  467.     
  468. RETURN CDOW(mdate)+", "+cmonth(mdate)+" "+;
  469.          ltrim(str(day(mdate),2))+", "+str(year(mdate),4)
  470.  
  471. *---------------------------------------------------------------------
  472.  
  473. FUNCTION zipok
  474.  
  475.     ** from Miriam Liskin
  476.     ** checks valid ZIP CODE or Foreign Postal Code
  477.     
  478.     parameters mzip,mcountry
  479.     
  480.     mdigits = "0123456789"
  481.     
  482.     do case        && check country -- currently set for usa/canada only
  483.         case mcounter = " "        && usa
  484.             if len(trim(mzip)) <> 5 .and. len(trim(mzip)) <> 10
  485.                 RETURN .F.
  486.             endif                     && must be 5 or 10 in size
  487.             mcount = 1
  488.             DO WHILE mcount <= len(trim(mzip))  && check each character
  489.                 if mcount = 6
  490.                     if substr(mzip,mcount,1) <> "-" && character must be dash
  491.                         return .f.
  492.                     endif
  493.                 else    && check the other characters to make sure they're digits
  494.                     if .not. substr(mzip,mcount,1) $ mdigits
  495.                         return .f.
  496.                     endif    && check for digits
  497.                 endif    && pointer at 6
  498.                 mcount = mcount + 1    && increment counter/pointer
  499.             enddo    && end of loop
  500.         case upper(mcountry) = "CANADA"
  501.             if len(trim(mzip)) <> 7        && length of zip is 7
  502.                 return .f.
  503.             endif
  504.             mcount = 1
  505.             do while mcount <= 7
  506.                 do case
  507.                     case mcount = 2 .or. mcount = 5 .or. mcount = 7 .and.;
  508.                         .not. substr(mzip,mcount,1) $ mdigits
  509.                         return .f.    && 2,5,7 gotta be digits
  510.                     case mcount = 1 .or. mcount = 3 .or. mcount = 6 .and.;
  511.                         .not. isalpha(substr(mzip,mcount,1))
  512.                         return .f.    && 1,3,6 gotta be alpha
  513.                     case mcount = 4 .and. substr(mzip,mcount,1)<> " "
  514.                         return .f.    && 4 gotta be a space
  515.                 endcase
  516.                 mcount = mcount + 1
  517.             enddo
  518.         endcase
  519.         
  520. RETURN .T.    && if here, we return true to function, otherwise it's false
  521.                 *   from any of the returns above
  522.  
  523. *---------------------------------------------------------------------
  524.  
  525. FUNCTION Isunique
  526.  
  527.     ** from Miriam Liskin, minor mods by Rick Price
  528.     ** Used to determine if a keyfield is unique
  529.         
  530.     parameters mvar
  531.         
  532.     mrecord = recno()    && store current record number
  533.     munique = .t.        && init to true
  534.     m_dbf = alias()    && store current alias, so we can return to it
  535.     SELECT DupCheck    && second copy of database    
  536.         
  537.     SEEK mvar        && make sure database is set to correct index here
  538.     locate for keyfield = mvar .and. recno() <> mrecord REST
  539. *                ^^^^^^^^                               *
  540. * ========>    MUST BE KEYFIELD IN DATABASE <========== *
  541.     if found()            && might need to replace with "keyfield = mvar" from above
  542.         munique = .f.
  543.     endif
  544.         
  545.     SELECT (m_dbf)        && back to original copy of file
  546.     
  547. RETURN munique        && return value of that field
  548.  
  549. *---------------------------------------------------------------------
  550.  
  551. PROCEDURE shadowg
  552.  
  553. parameters ln_x1,ln_y1,ln_x2,ln_Y2
  554.  
  555.     ln_x0 = ln_x2+1
  556.     ln_y0 = ln_y2+2
  557.     ln_dx = 1
  558.     ln_dy = (ln_y2-ln_y1) / (ln_x2-ln_x1)
  559.     DO WHILE ln_x0 <> ln_x1 .or. ln_y0 <> ln_y1+2
  560.         @ ln_x0,ln_y0 FILL TO ln_x2+1,ln_y2+2 COLOR n+/n
  561.         ln_x0 = IIF(ln_x0<>ln_x1,ln_x0 - ln_dx,ln_x0)
  562.         ln_y0 = IIF(ln_y0<>ln_y1+2,ln_y0 - ln_dy,ln_y0)
  563.         ln_y0 = IIF(ln_y0<ln_y1+2,ln_y1+2,ln_y0)
  564.     ENDDO
  565.     
  566. RETURN  && from procedure SHADOWG
  567.  
  568. *---------------------------------------------------------------------
  569. * End of procedure File
  570. *---------------------------------------------------------------------
  571.