Programmer 7500

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

/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / BASIC / GLIB14.ZIP / FED-DEMO.BAS < prev next >

Wrap

BASIC Source File | 1988-02-06 | 20.2 KB | 572 lines

REM $TITLE: 'FED - DEMO' REM $SUBTITLE: 'Text input demo ' REM (C) InfoSoft, 1987, 1988 COMMON /fedvars/ fg%, bg%, fgd%, bgd%, alarm%, edited%, nums%, num$, upcase% CLEAR DEFINT A-Z OPTION BASE 1 TYPE structure nname AS STRING * 25 phone AS STRING * 8 addr AS STRING * 25 city AS STRING * 10 state AS STRING * 2 zip AS STRING * 5 dept AS STRING * 6 superv AS STRING * 12 pfreq AS STRING * 1 prate AS SINGLE pin AS INTEGER END TYPE DIM emp AS structure 'make sure it is set up right CLS : SOUND 750, 2: LOCATE 5, 5 PRINT "Depending on your display, you may want to restart this demo" LOCATE 7, 5 PRINT "with the command line parameter [/CMD /NC] or [/CMD /C]. /NC for" LOCATE 9, 5 PRINT "No Color, /C for color version. This should be noted in F-DEMO.BAT" LOCATE 13, 5 PRINT "Tap `S' to stop the demo, any other key to continue." GOSUB wait.key IF ky$ = "S" OR ky$ = "s" THEN GOTO ext END IF '*********** get command line parms and set colors DIM arg$(2): q% = 0 FOR x = 1 TO 2 arg$(x) = SPACE$(LEN(COMMAND$) / 2) NEXT x CALL cmdline(arg$(), q%) IF arg$(1) = "/NC" THEN ' find out if command line wants color fg = 7: bg = 0 fge = 15: bge = 0 fgw = 0: bgw = 7 fgd = 15: bgd = 0 fgh = 7: bgh = 15 fgb = 15: bgb = 0 fgt = 7: bgt = 0 ELSE fg = 2: bg = 0 ' general colors fge = 12: bge = 3 ' err message colors fgw = 14: bgw = 4 ' window colors fgd = 10: bgd = 0 ' data colors fgh = 15: bgh = 1 ' help colors fgb = 4: bgb = 0 ' box color fgt = 3: bgt = 0 ' text colors END IF eattr = (bge * 16) + fge ' error message attributes wattr = (bgw * 16) + fgw ' window attributes hattr = (bgh * 16) + fgh ' help window attributes REM $DYNAMIC REDIM sarry(4000) 'dimension screen array for 2 screens REM $STATIC GOSUB set.pointers DIM hlp$(10) ' String array to hold help screen msgs for use later. ' Has to be DIMmed in code prior to other references ' to hlp$(). hlp$(1) = "Home - Start of line End - End of line" hlp$(2) = " " hlp$(3) = "Ctrl-X Clear Field Ctrl-End Clear to end of line" hlp$(4) = "Ctrl-U Undo <Arrows> Fwd, Bkwd 1 field " hlp$(5) = " " hlp$(6) = " PgUp / Ctrl PgUp - Jump to first field " hlp$(7) = " PgDn / Ctrl PgDn - Jump to last field " hlp$(8) = " " hlp$(9) = "[Esc] or [F9] Aborts Current Edit [F10] Save Record" hlp$(10) = "[ Tap any key to continue ]" prg.start: '*************** start of program ***************** GOSUB gen.disp ' put screen mask on screen CALL svscrn(segmt1, sptr1) ' save it - RSTSCRN is quicker next time GOSUB openfil ' open the file IF hi = 0 THEN GOSUB newfil recno = hi ' get the top rec no GOSUB rec.disp ' display given record '***************************************************************************** '* Each label below the sets up the flags and variables for editing for one * '* of the fields in the database or on the screen. A MAJOR part of the * '* Field EDitor (FED), is in the subroutine called CHGFLD, which routes the * '* flow of the code to the appropriate points. The random access file * '* contained here is pretty minimal - just enough to be able to demo FED. * '* In a "real" random file application, there are a number of things that * '* should be done in the way of checking for valid data, also, there are * '* functions missing like to delete a record (missing because it does not * '* lend itself to demoing FED or GIZLIB). There ARE several other GIZLIB * '* functions used: ERRMSG, DLRFRMAT, NFRMAT, WDW and a few others. * '***************************************************************************** ed.n: '----- edit name ------ LOCATE 4, 10 ' FED parameters upcase = 1 nums = 0 alarm = 1 ' turn caps only ON, nums only OFF, fsiz = 25 ' error sound ON, set size of string CALL fed(mname$, fsiz%, fcode%) '--- handles part of the return from FED ---------- IF fcode = 5 THEN ' if up arrow, go up one GOTO ed.n ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ' if down or enter pressed, just advance one field ed.p: ' ----- edit phone number --------- LOCATE 4, 57 upcase = 0: nums = 1: num$ = "1234567890-": bleep = 1 fsiz = 8: temp$ = mphone$ ' save a copy of phone in case of error CALL fed(temp$, fsiz%, fcode%) m = 2: p = 0 ' m sets NFRMAT mode, p is useless here CALL nfrmat(temp$, m, p) IF m = 2 THEN ' if format went okay mphone$ = temp$ ' assign value to memory var ELSE ' something went wrong !! CALL errmsg(temp$, 24, eattr%, 2) ' tell them of error GOTO ed.p ' note that we do not know what the END IF ' error is! Just that there is one IF fcode = 5 THEN ' up arrow... GOTO ed.n ' ...back up one field ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.a: '----- edit address ----- LOCATE 6, 13 nums = 0: upcase = 0: alarm = 1 fsiz = 25: ' nums only OFF, caps OFF, bleepr ON CALL fed(maddr$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.p ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.c: ' ----- edit city ----- LOCATE 8, 10 upcase = 1: nums = 0: alarm = 1 fsiz = 10 ' caps ON, nums only OFF, sound ON CALL fed(mcity$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.a ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.s: ' ----- edit state ----- LOCATE 8, 42 fsiz = 2: alarm = 0 ' turn sound ON, set size CALL fed(mstate$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.c ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.z: '----- edit zip code ----- LOCATE 8, 60 nums = 1: num$ = "1234567890": alarm = 0 fsiz = 5 ' turn nums only ON, bleepr OFF CALL fed(mzip$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.s ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.d: '----- edit department ----- LOCATE 12, 16 upcase = 1: nums = 0: alarm = 1 fsiz = 6 ' caps ON, nums only OFF, bleepr ON CALL fed(mdept$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.z ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.sv: '----- edit supervisor name ----- LOCATE 12, 57 fsiz = 12 ' same bleepr, caps and nums state CALL fed(msuperv$, fsiz%, fcode%) IF fcode = 5 THEN ' up arrow GOTO ed.d ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.pf: '----- edit pay freq ----- LOCATE 14, 41 fsiz = 1 ' same caps etc settings temp$ = mpfreq$ ' save a copy cause they can CALL fed(temp$, fsiz%, fcode%) ' screw it up temp$ = UCASE$(temp$) IF INSTR("HS", temp$) = 0 THEN CALL errmsg("Pay Frequency code must be H or S only.", 24, eattr%, 2) GOTO ed.pf END IF mpfreq$ = temp$ ' assign correct one IF fcode = 5 THEN ' up arrow GOTO ed.sv ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.r: '----- edit pay rate ----- LOCATE 14, 70 'turn nums only on, turn OFF bleepr nums = 1: num$ = "1234567890.$" alarm = 0 fsiz = 6: temp$ = mprat$ CALL fed(temp$, fsiz%, fcode%) m = 0: p = 2 ' set up for dollar formatting call CALL dlrfrmat(temp$, m%, p%) IF m <> 0 THEN ' if m is changed CALL errmsg(temp$, 24, eattr, 2) ' GOTO ed.r END IF mprat$ = temp$ IF fcode = 5 THEN ' up arrow GOTO ed.pf ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF ed.pin: '----- edit PIN code ----- LOCATE 16, 17: PRINT mpin$ ' it is previuosly hidden nums = 1: num$ = "1234567890" alarm = 0: fsiz = 4 ' bleep is same as last one, but LOCATE 16, 17 ' they can JUMP here via PgDn CALL fed(mpin$, fsiz%, fcode%) LOCATE 16, 17: PRINT STRING$(4, 254) ' re hide their code IF fcode = 5 THEN ' up arrow GOTO ed.r ELSEIF fcode <> 6 OR fcode <> 0 THEN ' if NOT down or enter GOSUB chgfld ' see where they want to go END IF savrec: ' save a record GOSUB closefil ' LSET and close the file edt = 0 ' reset the edit flag GOSUB show.rec ' show the new version GOTO ed.n ' go to first field ext: SYSTEM '================================[ SUBROUTINES ]============================== '****************************************************************************** '* In the way that FED is implemented here, most all of the FED Exit codes * '* (aka FCODE), can be handled in a gosub to something like the following. * '* Regardless of what field they are editting, F9, F10, F1, PgUp, PgDn etc * '* all mean the same thing: abort, save, help, Jump to start, jump to end etc * '* The only FCODE that cannot be handled here (given the way that I have * '* this implementation set up) is and Up Arrow (fcode=5). ENTER, and Dn Arrow* '* (fcodes 0 and 6) are not handled here or at all actually, they "fall thru" * '* to the next label rather than being routed here. * '* Some sort of routine like this is essential to FED's operation. * '****************************************************************************** chgfld: IF edt THEN ' This part is not critical, COLOR bgb, fgb ' but shows user when current LOCATE 1, 35 ' record is different from data PRINT " [ EDITING ] " ' in file. ELSE COLOR fgb, bgb LOCATE 1, 38 PRINT STRING$(15, 205); ' overwrite EDITING flag END IF COLOR fg, bg SELECT CASE fcode ' CASE is new to QB 3.0 - will not compile in 2.x CASE 1 ' F1 key pressed (HELP) CALL svscrn(segmt2, sptr2) ' save screen as is CALL wdw(7, 12, 17, 72, 1, 1, 2, hattr, "Editing Help") FOR x = 1 TO 9 ' pop help window up CALL quikprt(hlp$(x), 7 + x, 14, hattr%) NEXT x ' QUIKPRT help msgs LOCATE 18, 30: COLOR fgh, bgh: PRINT hlp$(10) GOSUB wait.key ' wait for any key CALL rstscrn(segmt2, sptr2) ' restore pre help screen RETURN ' RETURN to next label CASE 3 ' F3 page back a record IF edt THEN ' they have changed something CALL errmsg("You cannot PAGE until current edit is saved.", 24, eattr%, 2) RETURN END IF IF recno > 1 THEN recno = recno - 1 ' back up a record CALL rstscrn(segmt1, sptr1) ' restore blank screen (bleed thru) GOSUB rec.disp ' display desired record RETURN ed.n ' goto first field CASE 4 ' F4 page forward a record IF edt THEN ' they have changed something CALL errmsg("You cannot PAGE until current edit is saved.", 24, eattr%, 2) RETURN END IF IF recno < hi THEN recno = recno + 1 ' forward a record CALL rstscrn(segmt1, sptr1) GOSUB rec.disp ' display desired record RETURN ed.n ' goto first field CASE 7 ' F7 add a record IF edt THEN CALL errmsg("Cannot ADD until current EDIT is saved.", 24, eattr, 2) ELSE recno = hi + 1 ' increment record pointer ' ---- set all mem vars to nul strings ----- mname$ = "": mphone$ = "": maddr$ = "": mcity$ = "": mstate$ = "" mzip$ = "": mdept$ = "": msuperv$ = "": mpfreq$ = "" mprat$ = "": mpin$ = STRING$(4, 254) CALL rstscrn(segmt1, sptr1) GOSUB show.rec ' display RETURN ed.n END IF CASE 8 ' F8 - quit demo SYSTEM CASE 9, 15 ' F9, ESC recno = 1 ' this should have a "ARE YOU SURE" GOSUB rec.disp ' prompt if it was more than demo RETURN ed.n ' redisplay current record CASE 10 ' F10 save record RETURN savrec CASE 11, 13 'Pg Up or ^Pg Up RETURN ed.n CASE 12, 14 'Pg Dn or ^Pg Dn RETURN ed.pin CASE ELSE ' handles all other fed codes RETURN ' (F2, etc - advance a field) END SELECT openfil: '----------- open demo file statements --------- OPEN "emp.dat" FOR RANDOM AS #1 LEN = LEN(emp) sof = LOF(1) / LEN(emp) ' sof is number of records in file hi = sof ' hi is high record number RETURN closefil: '------------- store the record --------------- emp.nname = mname$: emp.phone = mphone$: emp.addr = maddr$ emp.city = mcity$: emp.state = mstate$: emp.zip = mzip$ emp.dept = mdept$: emp.superv = msuperv$: emp.pfreq = mpfreq$ emp.prate = VAL(mprat$): emp.pin = VAL(mpin$) PUT #1, recno, emp ' move record to buffer CLOSE #1 ' actually put file to disk GOSUB openfil ' open file again in updated state RETURN rec.disp: '---------- put selected record to the screen ----------- ' convert to memory variable to edit a COPY ' of each and strip trailing blanks GET #1, recno, emp mname$ = emp.nname: mname$ = RTRIM$(mname$) mphone$ = emp.phone: mphone$ = RTRIM$(mphone$) maddr$ = emp.addr: maddr$ = RTRIM$(maddr$) mcity$ = emp.city: mcity$ = RTRIM$(mcity$) mstate$ = emp.state: mstate$ = RTRIM$(mstate$) mzip$ = emp.zip: mzip$ = RTRIM$(mzip$) mdept$ = emp.dept: mdept$ = RTRIM$(mdept$) msuperv$ = emp.superv: msuperv$ = RTRIM$(msuperv$) mpfreq$ = emp.pfreq: mpfreq$ = RTRIM$(mpfreq$) mprat$ = STR$(emp.prate): mprat$ = RTRIM$(LTRIM$(mprat$)) CALL dlrfrmat(mprat$, 2, 2) mpin$ = STR$(emp.pin): mpin$ = RTRIM$(LTRIM$(mpin$)) show.rec: ' display the record IF edt THEN ' This part is not critical, COLOR bgb, fgb ' but shows user when current LOCATE 1, 35 ' record is different from data PRINT " [ EDITING ] " ' in file. ELSE COLOR fgb, bgb LOCATE 1, 35 PRINT STRING$(15, 205); END IF COLOR fg, bg COLOR fg, bg LOCATE 4, 10: PRINT mname$ LOCATE 4, 57: PRINT mphone$ LOCATE 6, 13: PRINT maddr$ LOCATE 8, 10: PRINT mcity$ LOCATE 8, 42: PRINT mstate$ LOCATE 8, 60: PRINT mzip$ LOCATE 12, 16: PRINT mdept$ LOCATE 12, 57: PRINT msuperv$ LOCATE 14, 41: PRINT mpfreq$ LOCATE 14, 70: PRINT mprat$ LOCATE 16, 17: PRINT STRING$(4, 254) LOCATE 16, 71: COLOR fgw, 0: PRINT recno% COLOR fg, bg edited = 0 ' set edit flag to show that record on screen is same as file RETURN gen.disp: '***************************************************************************** '* Routine to put general display on the screen, this is used once. After * '* it is put to the screen, it is saved via SVSCRN, and restored from there * '* rather than doing all these PRINTs again. * '***************************************************************************** CALL boxes(5, 1, fgb) 'put a big box on screen COLOR fgt + 8 LOCATE 2, 25: PRINT "XYZ Corporation Employee Data File" ' a title COLOR fgt LOCATE 4, 4: PRINT "Name: " LOCATE 4, 50: PRINT "Phone: " LOCATE 6, 4: PRINT "Address: " LOCATE 8, 4: PRINT "City: " LOCATE 8, 35: PRINT "State: " LOCATE 8, 55: PRINT "Zip: " LOCATE 12, 4: PRINT "Department: " LOCATE 12, 45: PRINT "Supervisor: " LOCATE 14, 4: PRINT "Hourly / Salary Level (H or S only): " LOCATE 14, 60: PRINT "Pay Rate: " LOCATE 16, 55: PRINT "Record Number: "; LOCATE 16, 4: PRINT "4 Digit PIN: " COLOR 4, 0: LOCATE 17, 1: PRINT CHR$(199) + STRING$(78, 196) + CHR$(182) COLOR fgt + 8: LOCATE 18, 30: PRINT "Editing Keys:": COLOR fgt LOCATE 20, 10: PRINT " [F8] - Quit [F9] - Abort Edit" LOCATE 19, 10: PRINT "[F1] - Help [F7] - Add Record [F10] - Save" LOCATE 21, 10: PRINT "[F3] - Page back one record [F4] - Page forward one record" LOCATE 22, 10: PRINT "[Enter] - Advances a field. [PgDn] - Jump to last field" LOCATE 23, 5: PRINT "[PgUp] - Jump to first field <Arrow Keys> Advance or back up one field." RETURN set.pointers: segmt1 = VARSEG(sarry(1)): sptr1 = VARPTR(sarry(1)) segmt2 = VARSEG(sarry(2001)): sptr2 = VARPTR(sarry(2001)) RETURN newfil: '---------------- make a new file if demo one got lost ------- mname$ = "JIM LOTUS" mphone$ = "555-0123" maddr$ = "1432 OAK STREET" mcity$ = "CENTERVILE" mstate$ = "MA" mzip$ = "01234" mdept$ = "EXEC." msuperv$ = "NONE" mpfreq$ = "S" mprat$ = "900.00" mpin$ = "1234" recno = 1 GOSUB closefil RETURN wait.key: '--------loop until a key is pressed - handy to have ky$ = "" DO UNTIL ky$ <> "" ky$ = INKEY$ LOOP RETURN REM x$include: 'fed.bas'