Liren Large Software Subsidy 5

home *** CD-ROM | disk | FTP | other *** search

/ Liren Large Software Subsidy 5 / 05.iso / a / a042 / 2.ddi / DEMO / MAIN.PRG < prev next >

Wrap

Text File | 1991-01-22 | 18.1 KB | 691 lines

* main.prg * please note that there have been minor modifications to this * code since the manual printing. Specifically, the routines for * trapping master.dat exclusion, trapping for non entry into the * new file create routine ( function notempty ), procedure mnameit * also had changes to assure that if you somehow manage to get out * from the valid in the get-read, you'll get caught emulating a cancel * button. Also, I added the window in front of the main loop to catch * if there were any files on the machine to "open". Tied with this also, * is anything using the numoffiles variable. I've used numoffiles = 0 * to tell cpu to bypass the loop and go directly to create new file using * the defaults set. STORE .T. TO mainloop SET WINDOW TITLE TO "Client Entry" SET PROCEDURE TO main STORE .F. TO isread,isprinter STORE 0 TO hm,vm,mc,ls,val,ev,count,i_event STORE " " TO ls,bt,cswind,openfile,chk,openindex,ck,bt STORE " " TO fileopen,xstate,xstate1,lst STORE .F. TO flopen,new numoffiles = adir("_*.dbf") DO menusetup do checkmasterdat DECLARE stlist[13] DO arraysetup IF ISCOLOR() SET GET VIDEO TO 249 SET READ VIDEO TO 249 SET EXIT VIDEO TO 249 ENDIF if numoffiles = 0 create window "NEW" from 5,5 to 15,40 beep ? "There are no files created." ? "Please, begin this demo by " ? "creating at least one database" ? ? "***" for i = 1 to 4 inkey(1) ?? "***" next close window "NEW" val = 2 vm = 1 hm = 1 endif DO WHILE mainloop IF flopen DO dispdata ENDIF if numoffiles <> 0 sit() endif isread = .F. IF val = 1 DO controlkeys ENDIF DO CASE CASE val = 2 DO CASE CASE hm = 1 DO CASE CASE vm = 1 DO mnameit IF .NOT. EMPTY(openfile) DO filecreate IF .NOT. EMPTY(openfile) DO en1 flopen = .T. fileopen = namechk("openfile") DO makebackupfile DO opendatafile DO buttonsetup ENDIF ENDIF CASE vm = 2 openfile = "_ " do while .t. STORE DBFMENU("_*.DBF") TO openfile do case case empty(openfile) exit case substr(openfile,rat("\",openfile)+1,1) = "_" exit endcase enddo IF .NOT. EMPTY(openfile) flopen = .T. fileopen = namechk("openfile") DO makebackupfile DO opendatafile DO buttonsetup ENDIF CASE vm = 3 DO savequestion SELECT B USE SELECT A USE DO dis1 DO buttonclose @ 0,0 CLEAR flopen = .F. STORE "" TO openindex,openfile,fileopen CASE vm = 5 DO savequestion CASE vm = 6 flo = openfile openfile = fileopen+SPACE(8-LEN(fileopen)) DO mnameit IF EMPTY(openfile) openfile = flo ELSE SELECT A USE DO makesaveas DO restdatafile fileopen = namechk("openfile") USE &openfile ENDIF CASE vm = 8 IF flopen DO savequestion ENDIF SELECT B USE SELECT A USE DO dis1 mainloop = .F. CLOSE MENU "MAIN" ENDCASE CASE hm = 2 DO CASE CASE vm = 1 && Printer xstate = isprint() IF xstate SET DEVICE TO PRINT ELSE DO buttonclose @ 0,0 CLEAR ENDIF DO clientreport IF xstate SET DEVICE TO SCREEN ELSE @ 0,0 CLEAR DO buttonsetup ENDIF CASE vm = 2 && Labels DO clientlabels ENDCASE GO TOP CASE hm = 3 DO about ENDCASE CASE val = 6 DO CASE CASE bt = " First " GO TOP CASE bt = " Last " GO BOTTOM CASE bt = " Next " SKIP IF EOF() GO BOTTOM ENDIF CASE bt = " Previous " SKIP -1 IF BOF() GO TOP ENDIF CASE bt = " Edit " STORE .T. TO isread CASE bt = " Delete " IF WARNING("DELETE","This will delete this record. Do you wish to proceed?",2) = 1 DELETE ENDIF CASE bt = " Add " STORE .T. TO isread APPEND BLANK CASE bt = " Search " DO searchfile ENDCASE ENDCASE ENDDO RETURN PROCEDURE about SET WINDOW TYPE TO 33 CREATE WINDOW "INFORMATION" FROM 5,25 TO 14,55 @ 0,08 SAY "dBFast/Windows" @ 1,06 SAY "Client Entry V1.0" @ 3,1 SAY "Written By Kim V. Phillips" @ 4,02 SAY "genSoft Development Corp." @ 6,04 SAY "Copyright ⌐ 1990,1991" CREATE BUTTON " OK " AT 8,11 DO WHILE .T. sit() IF bt = " OK " .AND. val <> 10 EXIT ENDIF ENDDO CLOSE WINDOW "INFORMATION" RETURN PROCEDURE arraysetup stlist[1] = "" stlist[11] = "WA" stlist[2] = "CA" stlist[3] = "ID" stlist[4] = "OR" stlist[5] = "NV" stlist[6] = "AZ" stlist[7] = "NM" stlist[8] = "MT" stlist[9] = "CO" stlist[10] = "UT" stlist[12] = "TX" stlist[13] = "WY" RETURN PROCEDURE buttonclose CLOSE BUTTON " Next " CLOSE BUTTON " Previous " CLOSE BUTTON " First " CLOSE BUTTON " Last " CLOSE BUTTON " Delete " CLOSE BUTTON " Add " CLOSE BUTTON " Edit " CLOSE BUTTON " Search " RETURN PROCEDURE buttonsetup CREATE BUTTON " Next " AT 17,10 CREATE BUTTON " Previous " AT 19,10 CREATE BUTTON " First " AT 17,24 CREATE BUTTON " Last " AT 19,24 CREATE BUTTON " Delete " AT 17,36 CREATE BUTTON " Add " AT 19,36 CREATE BUTTON " Edit " AT 17,48 CREATE BUTTON " Search " AT 19,48 RETURN PROCEDURE checkmasterdat if file ( "master.dat" ) return else warning( "MASTER.DAT file missing!" , ; "This file did not end up in the proper "+chr(13) + ; "directory, please recopy it from the" + ; chr(13) + "Installation diskette to your" + chr(13) + ; "working directory!" , 2 ) quit endif RETURN PROCEDURE clientreport GO TOP DO clientheading row = 5 DO WHILE .NOT. EOF() DO clientdetail SKIP INC row IF isprinter IF row > 59 EJECT DO clientheading row = 5 ENDIF ELSE IF row > 24 WAIT @ 0,0 CLEAR DO clientheading row = 5 ENDIF ENDIF ENDDO WAIT RETURN PROCEDURE clientdetail @ row, 2 SAY FIRST @ row,18 SAY LAST @ row,39 SAY CITY @ row,60 SAY STATE @ row,65 SAY ZIP RETURN PROCEDURE clientlabels GO TOP numoflines = 0 cont = 0 DO buttonclose DO labelalign IF cont = 2 DO buttonsetup RETURN ENDIF SET CONSOLE OFF SET PRINT ON PAGELTH(0) DO WHILE .NOT. EOF() ? ? TRIM(first)+" "+TRIM(last) INC numoflines IF .NOT. EMPTY(address1) ? TRIM(address1) INC numoflines ENDIF IF .NOT. EMPTY(address2) ? TRIM(address2) INC numoflines ENDIF ? TRIM(city)+", "+state+" "+zip INC numoflines DO CASE CASE numoflines = 2 ? ? ? CASE numoflines = 3 ? ? CASE numoflines = 4 ? ENDCASE SKIP ENDDO DO buttonsetup SET PRINT OFF SET CONSOLE ON RETURN PROCEDURE clientheading @ 1, 33 SAY "Client Report" @ 3, 3 SAY [Name] @ 3,39 SAY [City] @ 3,55 SAY [State] @ 3,62 SAY [Zip Code] RETURN PROCEDURE controlkeys DO CASE CASE ls = 14 val = 2 hm = 1 vm = 1 CASE ls = 15 val = 2 hm = 1 vm = 2 CASE ls = 19 val = 2 hm = 1 vm = 5 CASE ls = 24 val = 2 hm = 1 vm = 8 ENDCASE RETURN PROCEDURE dismenu DISABLE MENU 1 OFF DISABLE MENU 2 OFF DISABLE MENU 3 RETURN PROCEDURE dispdata @ 1, 1 SAY [Title] @ 3, 1 SAY [Client Name] @ 6, 1 SAY [Address] @ 10, 1 SAY [City] @ 10,38 SAY [State] @ 10,55 SAY [Zip Code] IF RECCOUNT() > 0 IF isread @ 1,13 SAY SPACE(4) @ 1,13 GET title RADIOBUTTON 'MR.;MRS.;MS.' HORIZONTAL ELSE @ 1,13 SAY title ENDIF @ 3,13 GET first @ 3,31 GET last @ 6,13 GET address1 @ 7,13 GET address2 @ 10,13 GET city IF isread @ 10,44 GET state VIEW SET LISTBOX TO 521 @ 05,48 get state LISTBOX @stlist VALID lstval() ELSE @ 10,44 GET state ENDIF @ 10,64 GET zip ENDIF RETURN PROCEDURE dis1 if numoffiles = 0 disable menu 1,2 off else * numoffiles = 1 enable menu 1,2 off endif DISABLE MENU 1,3 OFF DISABLE MENU 1,5 OFF DISABLE MENU 1,6 OFF ENABLE MENU 1,1 OFF ENABLE MENU 1,2 OFF DISABLE MENU 2 RETURN PROCEDURE enmenu ENABLE MENU 1 OFF ENABLE MENU 2 OFF ENABLE MENU 3 RETURN PROCEDURE en1 ENABLE MENU 1,3 OFF ENABLE MENU 1,5 OFF ENABLE MENU 1,6 OFF DISABLE MENU 1,1 OFF DISABLE MENU 1,2 OFF ENABLE MENU 2 RETURN PROCEDURE filecreate IF .NOT. FILE("MASTER.DAT") WARNING("ERROR","We require the file MASTER.DAT to be located in the current directory",1) openfile = SPACE(8) RETURN ENDIF COPY FILE master.dat TO &openfile SELECT A USE &openfile RETURN PROCEDURE labelalign DO WHILE .T. SET PRINT ON DO labeltest SET PRINT OFF STORE iscorrect("Label Alignment","Are the labels properly aligned?") TO cont DO CASE CASE cont = 0 && Yes EXIT CASE cont = 1 && No WARNING("RE-ALIGN"," Re-align the printer and select OK to continue",3) CASE cont = 2 && Cancel EXIT ENDCASE ENDDO RETURN PROCEDURE labeltest SET CONSOLE OFF ? "line 1" ? "line 2" ? "line 3" ? "line 4" ? "line 5" ? "line 6" SET CONSOLE ON RETURN FUNCTION lstval REPLACE GET state WITH state RETURN(.T.) PROCEDURE makebackupfile flo = SUBSTR(fileopen,1,AT(".",fileopen)-1) IF FILE(flo+".dbt") COPY FILE &FLO..DBT TO &FLO..DBO ENDIF COPY FILE &fileopen TO &flo..OLD RETURN PROCEDURE makesaveas flo = SUBSTR(fileopen,1,AT(".",fileopen)-1) flo1 = SUBSTR(openfile,1,AT(".",openfile)-1) IF FILE(flo+".dbt") COPY FILE &FLO..DBT TO &FLO1..DBT ENDIF COPY FILE &fileopen TO &flo1..DBF RETURN PROCEDURE menusetup CREATE POPUP MENU "File" FROM "New... ^N;Open...^O;Close;;Save ^S;Save As...;;Exit... ^X" AT 1,1 CREATE POPUP MENU "Reports" FROM "Client Report;Client Labels" AT 1,1 CREATE POPUP MENU "Help" FROM "About Client Entry..." AT 1,1 CREATE PULLDOWN MENU "MAIN" FROM "File","Reports","Help" SET MENU TO "MAIN" DO dis1 RETURN PROCEDURE mnameit SET WINDOW TYPE TO 4 CREATE WINDOW "FINAME" 4,5 TO 09,50 CLEAR CREATE BUTTON " OK " AT 3,30 CREATE BUTTON " CANCEL " AT 5,30 STORE ALLTRIM(openfile)+SPACE(7-LEN(ALLTRIM(openfile))) TO openfile @ 1,2 SAY "Create File Name:" @ 1,20 SAY CURRENTDIR() SET BOX ON DO WHILE .T. @ 3,2 GET openfile PICTURE "@!" valid notempty() READ @ 4,1 SAY SPACE(29) if empty(openfile) i_event = 6 bt = " CANCEL " endif IF i_event = 6 IF bt = " CANCEL " CLOSE WINDOW "FINAME" openfile = SPACE(7) chk = "C" RETURN ENDIF ENDIF openfile = "_" + ALLTRIM(openfile)+".DBF" IF FILE(openfile) @ 5,1 SAY "Name is already in use. Retry" ELSE numoffiles = 1 exit ENDIF STORE SPACE(8) TO openfile ENDDO CLOSE WINDOW "FINAME" RETURN function notempty if empty(openfile) return(.f.) else return(.t.) endif PROCEDURE opendatafile SELECT A USE &openfile STORE STUFF(openfile,AT(".",openfile),4,".NDX") TO openindex IF .NOT. FILE(openindex) INDEX ON UPPER(last)+UPPER(first) TO &openindex ENDIF SET INDEX TO &&openindex DO en1 flopen = .T. RETURN PROCEDURE restdatafile flo = SUBSTR(fileopen,1,AT(".",fileopen)-1) IF FILE(flo+".dbt") COPY FILE &flo..DBO TO &flo..DBT ENDIF COPY FILE &flo..OLD TO &fileopen RETURN PROCEDURE savequestion IF WARNING(fileopen,"Do you wish to save this data file?",2) = 0 DO restdatafile ELSE SELECT A USE DO makebackupfile SELECT A USE &openfile ENDIF RETURN PROCEDURE searchfile SET WINDOW TYPE TO 4 CREATE WINDOW "SEARCH" FROM 5,20 TO 11,60 @ 0,7 SAY "ENTER NAME TO SEARCH FOR" STORE SPACE(15) TO firstname STORE SPACE(20) TO lastname @ 2,2 SAY "First Name " GET firstname @ 4,2 SAY "Last Name " GET lastname READ IF .NOT. EMPTY(lastname) LOCATE FOR UPPER(lastname)+UPPER(firstname) = UPPER(last)+UPPER(first) ENDIF CLOSE WINDOW "SEARCH" RETURN FUNCTION iscorrect PARAMETER wtitle,wmessage CREATE WINDOW "ISCORRECT" FROM 5,20 TO 12,60 SET WINDOW TITLE TO wtitle CREATE BUTTON " YES " AT 5,7 CREATE BUTTON " NO " AT 5,17 CREATE BUTTON "CANCEL" AT 5,26 LOAD BITMAP MONOQUES.BMP INTO bitmapvar @ 0,0 say bitmapvar @ POINT 22,60 SAY wmessage DO WHILE .T. sit() IF val = 6 DO CASE CASE bt = " YES " retval = 0 CASE bt = " NO " retval = 1 CASE bt = "CANCEL" retval = 2 ENDCASE EXIT ENDIF ENDDO CLOSE WINDOW "ISCORRECT" RETURN(retval) FUNCTION isprint CREATE WINDOW "ISPRINT" FROM 5,20 TO 12,60 SET WINDOW TITLE TO "Client Report" CREATE PICTURE BUTTON "printer" AT 3,10 FROM FILE "monoprnt.bmp" CREATE PICTURE BUTTON "screen" AT 3,24 FROM FILE "monoscrn.bmp" @ 0,6 SAY "Select where you would like" @ 1,6 SAY " the output sent. " DO WHILE .T. SIT() IF val = 6 DO CASE CASE bt = "printer" log = .T. EXIT CASE bt = "screen" log = .F. EXIT ENDCASE ENDIF ENDDO CLOSE BUTTON "printer" CLOSE BUTTON "screen" CLOSE WINDOW "ISPRINT" RETURN(log) FUNCTION namechk PARAMETER namfile IF "\" $ &namfile STORE UPPER(SUBSTR(&namfile,RAT("\",&namfile)+1,LEN(&namfile)-RAT("\",&namfile))) TO namfile2 ELSE namfile2 = &namfile ENDIF RETURN(namfile2) FUNCTION sit @ 0,0 SAY "" IF .NOT. isread | if no read is required we strip for CLEAR GETS | events. val1 = -1 | DO WHILE val1 = -1 | do this loop until an event occurs and val1 = CHKEVENT() | changes value from -1. ENDDO val = val1 | DO WHILE val1 <> -1 | Now, strip off the top values from the i_event = EVENT() | event stack until it clears itself. val1 = CHKEVENT() | This is neccessary to check for the IF val1 <> -1 | multiple events that can occur under windows. val = val1 | event() READS the value but does not remove ENDIF ENDDO | it from the cue where chkevent() does. ELSE isread | if read, we do not strip because there is READ | no stack, it just reads the first event. * IF lst = 'Y' * READ START WITH 7 * lst = " " * ENDIF val = EVENT() ENDIF hm = HMENU() | These are all public variables vm = VMENU() | that I store values here so that I mr = MROW() | do not have to clutter up the actual mc = MCOL() | working code. ls = LASTKEY() | bt = BUTTON() | cswind = WINDOW() | RETURN(.T.)