********************************************************************** *-- Name.......: PROC.PRG *-- Programmer.: Kenneth J. Mayer, SofTech, Inc. *-- Date.......: 3/4/90 *-- Version....: dBASE IV, 1.1 *-- Notes......: This is a generic procedure file. * Sources: Rick Price (Hammett on ATBBS) * Liskin's dBASE IV Programming Book * (Miriam Liskin) * Ashton-Tate (ShadowG) ********************************************************************* *-- Note that to use this program file, the program must have the line *-- in it stating SET PROCEDURE TO PROC (usually early in the prog.) *-- When done, it is a good idea to close the procedure file, using the *-- command SET PROCEDURE TO *===================================================================== * * open_screen Used to give a texture to the background of the screen. * USAGE: do open_screen * * do_wait Used in place of the standard WAIT command, deals with * centering the text at the message line (row 24). * USAGE: lf_wait = do_wait("message") * OR * lf_wait = do_wait("") && default message * * jazclear Used to clear the screen from the middle out -- fancy clear * could be used with open_screen, to really fancify things! * USAGE: do jazclear * * center Centers text on the screen with @says * USAGE: DO CENTER with row,screenwidth,"color(s),"message" * EXAMPLE: DO CENTER WITH 5,80,"rg+/r",". . . PRINTING . . ." * * surround Displays a message surrounded by a box anywhere on the screen * USAGE: DO SURROUND WITH row,column,"colors","text" * * message Displays a message, centered, pauses until user presses a key * USAGE: DO MESSAGE WITH row,screenwidth,"colors","text" * * message2 Displays a message in a window, pauses for user to press key * USAGE: DO MESSAGE2 WITH "Text" * * message3 Displays a message in a window, pauses for user, will wrap a * long message inside the window. * USAGE: DO MESSAGE3 WITH "text" * * message4 Displays a 2-line message in a predefined window and pauses * USAGE: DO MESSAGE4 WITH "text1","text2" * * monitor Displays a status message to monitor a long-running operation * that operates on multiple records . . . * USAGE: DO MONITOR WITH "text" * DO WHILE (or SCAN) * stuff -- process records * @4,x DISPLAY ltrim(str(recno())) && current record * && in window MONITOR * ENDDO (endscan) * DEACTIVATE WINDOW MONITOR * RELEASE WINDOW MONITOR * * scrnhead Displays a heading on the screen in a box 2 spaces wider than * the text, with a custom border (double line top, single the * rest) * USAGE: DO SCRNHEAD WITH "colors","Text" * * yesno Asks a yes/no question in a dialog window/box * USAGE: ll_yesno = .t. && or .f. depending on what is needed * && returns .t. or .f. from procedure * && value here is default for procedure * DO YESNO WITH LL_YESNO,"Message" * if ll_yesno && do some stuff * * yes These two procedures are a part of the yesno procedure above. * no * * datetext Display date in format Month, day year (eg July 1, 1991) * USAGE: DATETEXT(datefield) * * datetxt2 Display date in format dayofweek, month day, year * (eg Monday, July 1, 1991) * USAGE: DATETXT2(datefield) * * zipok checks valid zipcode (US) or postal code (other) * USAGE: ZIPOK(zipfield) * * isunique Checks a keyfield to see if it is a unique entry * USAGE: USE database ORDER tag ALIAS aliasname * USE database ORDER tag ALIAS DupCheck AGAIN * * second use of database is read only for ISUNIQUE * @x,y SAY "prompt" GET mvar PICTURE "picture"; * valid required ISUNIQUE(mvar); * message "Enter a UNIQUE code"; * error chr(7)+"Field must be unique!" * where 'mvar' is memory variable/field being checked against * a specific 'field'. Make sure the correct index is set * as this function uses the SEEK command. * ALSO modify the field in the function below. * * shadowg Creates a shadow for a window (taken from the dBASE IV * picklist commands) * USAGE: SAVE SCREEN TO temp * DEFINE WINDOW name FROM trow,tcol TO brow,bcol DOUBLE * DO shadowg WITH trow,tcol,brow,bcol * ACTIVATE WINDOW name * perform actions in window * DEACTIVATE WINDOW name * RESTORE SCREEN FROM temp *===================================================================== PROCEDURE open_screen ** Designed to give fancy opening screen -- written by Rick Price ** stolen agregiously by Ken Mayer (with Rick's permission) clear x=0 lc_Backdrp = chr(176) && chr(176) = "°" do while x<3 @x,0 to x+3,79 lc_Backdrp && display this box sx=x x=x+6 @x,0 to x+3,79 lc_Backdrp x=x+6 @x,0 to x+3,79 lc_Backdrp x=x+6 @x,0 to x+3,79 lc_Backdrp x = sx+1 enddo @24,0 to 24,79 lc_Backdrp RETURN && end of procedure open_screen *--------------------------------------------------------------------- FUNCTION Do_Wait ** Another routine stolen from Rick Price to handle the need for ** a wait, but killing the ESCAPE key, amongst other things. parameters lc_Message lc_WaitCur = SET("CURSOR") && save status of cursor SET CURSOR OFF ** The the passed parameter (message_to_display) is null, use a generic ** message. lc_Message = ; iif(""=lc_Message," Press any key to continue . . . ",lc_Message) * deal with centering/truncating message ln_MesLen = LEN(lc_Message) lc_Message = iif(ln_MesLen>80,LEFT(lc_Message,80),lc_Message) ln_MesLen = LEN(lc_Message) && reset if message was longer than 80 @24,INT((80-ln_MesLen)/2) say lc_Message COLOR r/w lc_RetStr=CHR(Inkey(0)) set cursor &lc_waitcur RETURN lc_RetStr && end of routine Do_Wait *--------------------------------------------------------------------- PROCEDURE JazClear ** also stolen from Rick Price -- another fancy screen clear ** explode outward from the center -- pretty fancy stuff ln_WinR1 = 0 && row 1 ln_WinR2 = 24 && row 2 ln_WinC1 = 0 && column 1 ln_WinC2 = 79 && column 2 ln_Step = 1 && amount to increment by mn_WinC1 = INT((ln_WinC2-ln_WinC1)/2)+ln_WinC1 mn_WinC2 = mn_WinC1+1 mn_WinR1 = INT((ln_WinR2-ln_WinR1)/2)+ln_WinR1 mn_WinR2 = mn_WinR1+1 ** Adjust step offset values: ln_ColOff & ln_RowOff ** Vertical steps - mn_WinR1-ln_WinR1 ln_TmpAdjR = int((ln_WinR2 - ln_WinR1)/2) ln_TmpAdjC = int((ln_WinC2 - ln_WinC1)/2) ln_AdjRow = ; iif(ln_TmpAdjC > ln_TmpAdjR, ln_TmpAdjR/ln_TmpAdjC,1) * ln_Step ln_AdjCol = ; iif(ln_TmpAdjR > ln_TmpAdjC, ln_TmpAdjC/ln_TmpAdjR,1) * ln_Step ln_colleft = ln_WinC1 ln_colrite = ln_WinC2 ln_RowTop = ln_WinR1 ln_RowBot = ln_WinR2 ln_WinC1 = mn_WinC1 ln_WinC2 = mn_WinC2 ln_WinR1 = mn_WinR1 ln_WinR2 = mn_WinR2 DO WHILE (ln_WinC1#ln_ColLeft .or. ln_WinC2#ln_ColRite .or. ; ln_WinR1 # ln_RowTop .or. ln_WinR2 # ln_RowBot) * Adjust coordinates for the clear (moving out from the middle) ln_WinR1 = ; ln_WinR1-IIF(ln_RowTopln_WinR2+ln_AdjRow,ln_AdjRow,ln_RowBot-ln_WinR2) ln_WinC1 = ; ln_WinC1-IIF(ln_ColLeftln_WinC2+ln_AdjCol,ln_AdjCol,ln_ColRite-ln_WinC2) * Perform the clear @ln_WinR1,ln_WinC1 CLEAR TO ln_WinR2,ln_WinC2 @ln_WinR1,ln_WinC1 TO ln_WinR2,ln_WinC2 ENDDO CLEAR RETURN && from JazClear *--------------------------------------------------------------------- PROCEDURE center ** Used to center text on the screen with @SAYs, stolen from Miriam ** Liskin's dBASE IV Programming Book PARAMETERS mline,mwidth,mcolor,mtext mtext = trim(mtext) mcol = (mwidth-len(mtext))/2 @mline,mcol say mtext color &mcolor. RETURN && from procedure center *--------------------------------------------------------------------- PROCEDURE Surround ** from Miriam Liskin's Book ** Displays text surrounded by a box anywhere on the screen parameters mline,mcolumn,mcolor,mtext mtext = " " + TRIM(mtext) + " " && add spaces around text @mline-1,mcolumn-1 to mline+1,mcolumn+LEN(mtext) DOUBLE; color &mcolor. @mline,mcolumn SAY mtext COLOR W+/B && bright white on blue RETURN && from procedure Surround *--------------------------------------------------------------------- PROCEDURE Message ** from Miriam Liskin's Book ** Displays a centered message and pauses until user presses a key ** uses CENTER above parameters mline,mwidth,mcolor,mtext @mline,0 do center WITH mline,mwidth,mcolor,mtext wait "" @mline,0 RETURN && from procedure Message *--------------------------------------------------------------------- PROCEDURE Message2 ** from Miriam Liskin's Book ** Displays a message in a window and pauses until user presses a key parameters mtext DEFINE Window Message FROM 10,10 to 14,70 DOUBLE ACTIVATE Window Message Do Center WITH 1,60,"W+/B",mtext wait Deactivate Window Message Release Window Message RETURN && from Message2 *--------------------------------------------------------------------- PROCEDURE message3 ** From Miriam Liskin's Book ** displays message in a window and pauses until user presses a key Parameters mtext mlines = Int(len(mtext) / 38) + 5 && set # of lines for window DEFINE WINDOW message FROM 8,20 to 8+mlines,60 DOUBLE ACTIVATE WINDOW MESSAGE mlmargin = _lmargin mrmargin = _rmargin malignment = _alignment mwrap = _wrap _lmargin = 1 _rmargin = 38 _alignment = "CENTER" _wrap = .t. ?mtext ? WAIT " Press any key to continue . . ." _lmargin = mlmargin _rmargin = mrmargin _alignment = malignment _wrap = mwrap deactivate window message release window message RETURN && from procedure Message3 *--------------------------------------------------------------------- PROCEDURE message4 ** from Miriam Liskin's Book ** Display a message in a predefined window and pause parameters mtext1,mtext2 define window MONITOR from 10,10 to 18,70 double activate window MONITOR mlmargin = _lmargin mrmargin = _rmargin mwrap = _wrap _lmargin = 1 _rmargin = 58 _wrap = .t. ? mtext1 ? mtext2 ? wait " Press any key to continue . . ." _lmargin = mlmargin _rmargin = mrmargin _wrap = mwrap deactivate window MONITOR release window MONITOR RETURN && from procedure MESSAGE4 *--------------------------------------------------------------------- PROCEDURE monitor ** taken from Miriam Liskin's Book ** display a status message to monitor a long-running operation ** user must specify in processing the record# to place in the ** box on line 4 . . . Must also deactivate window MONITOR and ** release it from MEMORY parameters mtext define window MONITOR From 10,10 to 18,70 DOUBLE activate window monitor do center with 1,60,"",mtext do center with 2,60,"","Please do not interrupt" @4,10 say "Working on record of" + ltrim(str(reccount(),5)) RETURN && from procedure MONITOR *--------------------------------------------------------------------- PROCEDURE scrnhead ** taken from Miriam Liskin's Book ** Display a heading in a box 2 spaces wider than text with ** custom border (double line top, single line sides) parameters mcolor,mtext mtext = " "+TRIM(mtext)+" " mtextstart = (80-len(trim(mtext)))/2 @1,mtextstart-1 to 3,81-mtextstart 205,196,179,179,213,184,192,217; color &mcolor. @2, mtextstart say mtext color w+/b && bright white on blue RETURN && from procedure scrnhead *--------------------------------------------------------------------- PROCEDURE Yesno ** from Miriam Liskin's Book ** asks a Yes-No question in a dialog box! parameter manswer,mquestion DEFINE Window yesno FROM 8,20 to 15,60 double define menu yesno define pad yes of yesno Prompt "Yes" at 4,10 define pad no of yesno Prompt "No" at 4,25 On Selection Pad Yes of yesno Do Yes && defined below On Selection pad No of yesno Do No && defined below ACTIVATE Window yesno mlmargin = _lmargin && store system values mrmargin = _rmargin mwrap = _wrap _lmargin = 2 && set local values _rmargin = 38 _wrap = .t. ?mquestion ? if manswer ACTIVATE MENU yesno PAD Yes else ACTIVATE MENU yesno PAD No endif _lmargin = mlmargin && reset system values _rmargin = mrmargin _wrap = mwrap Deactivate Window yesno release window yesno release menu yesno RETURN && from procedure Yesno PROCEDURE Yes manswer = .t. Deactivate Menu RETURN PROCEDURE No manswer = .f. Deactivate Menu RETURN *--------------------------------------------------------------------- FUNCTION Datetext ** stolen from Miriam Liskin's book ** displays date in text format (e.g., July 1, 1991) parameters mdate RETURN CMONTH(mdate)+" "+ltrim(str(day(mdate),2))+", "+; str(year(mdate),4) *--------------------------------------------------------------------- FUNCTION datetxt2 ** from Miriam Liskin's book ** displays date in text format (e.g., Monday, July 1, 1991) parameters mdate RETURN CDOW(mdate)+", "+cmonth(mdate)+" "+; ltrim(str(day(mdate),2))+", "+str(year(mdate),4) *--------------------------------------------------------------------- FUNCTION zipok ** from Miriam Liskin ** checks valid ZIP CODE or Foreign Postal Code parameters mzip,mcountry mdigits = "0123456789" do case && check country -- currently set for usa/canada only case mcounter = " " && usa if len(trim(mzip)) <> 5 .and. len(trim(mzip)) <> 10 RETURN .F. endif && must be 5 or 10 in size mcount = 1 DO WHILE mcount <= len(trim(mzip)) && check each character if mcount = 6 if substr(mzip,mcount,1) <> "-" && character must be dash return .f. endif else && check the other characters to make sure they're digits if .not. substr(mzip,mcount,1) $ mdigits return .f. endif && check for digits endif && pointer at 6 mcount = mcount + 1 && increment counter/pointer enddo && end of loop case upper(mcountry) = "CANADA" if len(trim(mzip)) <> 7 && length of zip is 7 return .f. endif mcount = 1 do while mcount <= 7 do case case mcount = 2 .or. mcount = 5 .or. mcount = 7 .and.; .not. substr(mzip,mcount,1) $ mdigits return .f. && 2,5,7 gotta be digits case mcount = 1 .or. mcount = 3 .or. mcount = 6 .and.; .not. isalpha(substr(mzip,mcount,1)) return .f. && 1,3,6 gotta be alpha case mcount = 4 .and. substr(mzip,mcount,1)<> " " return .f. && 4 gotta be a space endcase mcount = mcount + 1 enddo endcase RETURN .T. && if here, we return true to function, otherwise it's false * from any of the returns above *--------------------------------------------------------------------- FUNCTION Isunique ** from Miriam Liskin, minor mods by Rick Price ** Used to determine if a keyfield is unique parameters mvar mrecord = recno() && store current record number munique = .t. && init to true m_dbf = alias() && store current alias, so we can return to it SELECT DupCheck && second copy of database SEEK mvar && make sure database is set to correct index here locate for keyfield = mvar .and. recno() <> mrecord REST * ^^^^^^^^ * * ========> MUST BE KEYFIELD IN DATABASE <========== * if found() && might need to replace with "keyfield = mvar" from above munique = .f. endif SELECT (m_dbf) && back to original copy of file RETURN munique && return value of that field *--------------------------------------------------------------------- PROCEDURE shadowg parameters ln_x1,ln_y1,ln_x2,ln_Y2 ln_x0 = ln_x2+1 ln_y0 = ln_y2+2 ln_dx = 1 ln_dy = (ln_y2-ln_y1) / (ln_x2-ln_x1) DO WHILE ln_x0 <> ln_x1 .or. ln_y0 <> ln_y1+2 @ ln_x0,ln_y0 FILL TO ln_x2+1,ln_y2+2 COLOR n+/n ln_x0 = IIF(ln_x0<>ln_x1,ln_x0 - ln_dx,ln_x0) ln_y0 = IIF(ln_y0<>ln_y1+2,ln_y0 - ln_dy,ln_y0) ln_y0 = IIF(ln_y0