' +-----------------------------------------------------------+ ' | | ' | WARNING WARNING WARNING | ' | ------- ------- ------- | ' | When you load this program into QuickBASIC 4.5, you must also | ' | load QuickBASIC's quick library. So, at the prompt enter: | ' | | ' | QB /L QB.QLB Cid.Bas | ' | | ' +--------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | CID.BAS - The Customer Information Database | ' | C I D | ' | | ' | Public Domain - FreeWare | ' | | ' +---------------------------------------------------------------------+ ' | To run program in the QuickBASIC environment, use: | ' | QB /L QB.QLB CID.BAS (Use QuickBASIC's own quick library) | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | Hi! My name is Don Smith. CID stands for the Customer Information | ' | Database. The CID program is Public Domain FreeWare. The CID | ' | program is based on Jose Garcia's DATABASE.BAS program. The CID | ' | program requires QuickBASIC's QB.QLB to load and QB.LIB to link. | ' | | ' | My program is CID.BAS, but it is based on Mr. Garcia's 1989 | ' | DATABASE.BAS. In DATABASE.DOC, Jose wrote that other programmers | ' | were free to use his program, but that programmers should include | ' | his comments. His exact comments were that "any of the code can be | ' | used by other programmers but I ask that the comments be left | ' | intact". I not only have left intact the comments of his SUBs | ' | and FUNCTIONs, but his documentation file, DATABASE.DOC, in its | ' | entirety is included below, at the end of the main module, just | ' | before the first SUB, SUB BigBox, begins. I have used some of his | ' | SUBs and some of my own. | ' | | ' | Here are thirteen of my own SUBs and three which I rewrote: | ' | | ' | (1) SUB BigBox (11) SUB SaveRestScrn | ' | (2) SUB BoxBoy (12) SUB SCMenu, | ' | (3) SUB CheckStatus (13) SUB WordWrap. | ' | (4) SUB CviCall -------------------- | ' | (5) SUB EditLoco Rewritten SUBs of | ' | (6) SUB Form Mr. Garcia: | ' | (7) SUB GetFileAttributes -------------------- | ' | (8) SUB Noise (14) SUB form | ' | (9) SUB OneLine (15) SUB edit | ' | (10) SUB PrintName (16) SUB txt.edit | ' | | ' | Here are three FUNCIONs and twelve SUBs of Mr. Garcia's which | ' | remain intact including their remarks: | ' | | ' | (1) FUNCTION finddeleted% (9) SUB menucall | ' | (2) FUNCTION nospace$ (10) SUB openfile | ' | (3) FUNCTION search% (11) SUB openindex | ' | (4) SUB dataentry (12) SUB reindex | ' | (5) SUB db.index (13) SUB sort | ' | (6) SUB delete (14) SUB switch | ' | (7) SUB displaydata (15) SUB updatendx | ' | (8) SUB endit | ' | | ' | SHOWOFF.EXE, PRINTDOC.EXE AND PRINTIT.EXE are ancillary programs | ' | which accompany CID.EXE. SHOWOFF.EXE, PRINTDOC.EXE AND PRINTIT.EXE | ' | were written by me and they are all Public Domain FreeWare. | ' | Showoff.Exe is an ASCII text file browser. PrintDoc.Exe is an | ' | ASCII text print program. PrintIt.Exe is a windows-ready print | ' | program. They are stand alone programs and may be used on other | ' | occasions. | ' | | ' | The CID program's documentation file is CID.DOC - it is selection | ' | <7> at the main menu. | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | - ABOUT THE AUTHOR - | ' +---------------------------------------------------------------------+ ' | | ' | Hello. My name is Don Smith and I am a retired Math/History/Spanish | ' | teacher residing in Orange County, California. I am also a former | ' | 6-year Sergeant of Marines. Who-Rah! On certain forums I am known | ' | as MarineDon. My email is: smithdonb@earthlink.net | ' | | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | - COPYING AND DISTIBUTING - | ' +---------------------------------------------------------------------+ ' | Since this code is public domain and freeware, anyone may freely | ' | copy and distribute it. If you use the QuickBasic code in one of | ' | your own programs, you do not have to cite my name as the author, | ' | and you may even change its name. | ' +---------------------------------------------------------------------+ ' +---------------------------------------------------------------------+ ' | To run CID.BAS in the QuickBASIC environment, please enter: | ' | | ' | QB /L QB.QLB CID.BAS (Note: Must use QuickBASIC's own quick | ' | library, QB.QLB, for SUB InterruptX. | ' | InterruptX is used to check if a file | ' | exists or not.) | ' +---------------------------------------------------------------------+ ' | COMPILE INFO: | ' | | ' | BC : CID /e /ah (/e for ON ERROR; /ah for large arrays) | ' | | ' | LINK: CID /noe | ' | | ' | LIB : QB BCOM45 | ' +---------------------------------------------------------------------+ ' Next 19 lines set up SUB GetFileAttributes and SUB InterruptX. ' CID uses these SUBs to check the existence of a file (for more ' information, go to SUB GetFileAttributes) TYPE RegTypeX ax AS INTEGER bx AS INTEGER cx AS INTEGER dx AS INTEGER bp AS INTEGER si AS INTEGER di AS INTEGER flags AS INTEGER ds AS INTEGER es AS INTEGER END TYPE TYPE FileAttributesType readOnly AS INTEGER hidden AS INTEGER systemFile AS INTEGER archive AS INTEGER result AS INTEGER END TYPE CONST False% = 0, True% = NOT False% '------------------------------------------------------------------------ DECLARE FUNCTION FindDeleted% (GetNum%) DECLARE FUNCTION NoSpace$ (SearchString$) DECLARE FUNCTION Search% (WhatText$) '------------------------------------------------------------------------ DECLARE SUB BigBox (RowUL%, ColUL%, RowLR%, ColLR%, ColrFG%, ColrBG%) DECLARE SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) DECLARE SUB CheckStatus (Trial%, NDXfile$, DATfile$, ErrExist%) DECLARE SUB CviCall (HitKey%) DECLARE SUB dataentry (FGColr%, BGColr%) DECLARE SUB Delete (FGColr%, BGColr%) DECLARE SUB displaydata (FGColr%, BGColr%) DECLARE SUB DB.Index () DECLARE SUB EditLoco (EdW$, Row%, Col%, FCol%, LenStr%, See%, TypeOfText$, Caps%, FGColr%, BGColr%, FKey$, Ins%, PW%, TabUpDn$, ExitCode%) DECLARE SUB Edit (FGColr%, BGColr%) DECLARE SUB endit (NDXfile$, DATfile$) DECLARE SUB form (FGColr%, BGColr%) DECLARE SUB GetInfo () DECLARE SUB GetFileAttributes (fileName$, attr AS FileAttributesType) DECLARE SUB getname (FGColr%, BGColr%) 'SUB InterruptX is part of QB.LIB and QB.QLB; it is NOT part of CID.BAS. DECLARE SUB InterruptX (intnum%, inreg AS RegTypeX, outreg AS RegTypeX) DECLARE SUB MenuCall (FGColr%, BGColr%, NDXfile$, DATfile$, ExistNum%) DECLARE SUB Noise () DECLARE SUB OneLine (LineRow%, LineCol%, LineFG%, LineBG%, Style%, LenStr%) DECLARE SUB OpenFile () DECLARE SUB OpenIndex () DECLARE SUB PrintName (PrnSet%, firsletter$, FGColr%, BGColr%) DECLARE SUB ReIndex (Target$) DECLARE SUB SaveRestScrn (ReadLine$(), ReadColr%(), SR.UL.Row%, SR.UL.Col%, SR.LR.Row%, SR.LR.Col%, SaveOrRest%) DECLARE SUB SDMenu (M$(), Row%, TopRow%, Col%, Num%, MaxItems%, FGColr%, BGColr%, HiLiteFG%, HiLiteBG%, SD%, TypeOfKeys$, FKeys$, selection%, ExitCode%) DECLARE SUB Sort () DECLARE SUB Switch (NUMBER%) DECLARE SUB Txt.Edit (Temps$(), FGColr%, BGColr%) DECLARE SUB updateNDX () DECLARE SUB WordWrap (X$, Wide%, PrnRow%, PrnCol%, FGColr%, BGColr%) DECLARE SUB YesOrNo () '------------------------------------------------------------------------ tippy.top: TYPE address ' first AS STRING * 20 last AS STRING * 20 address AS STRING * 55 city AS STRING * 25 state AS STRING * 2 zip AS STRING * 10 phone AS STRING * 60 ssnum AS STRING * 11 dob AS STRING * 10 comments1 AS STRING * 60 comments2 AS STRING * 60 comments3 AS STRING * 60 comments4 AS STRING * 60 comments5 AS STRING * 60 recnum AS INTEGER END TYPE TYPE indexrecord ' firstlast AS STRING * 40 recordnumber AS INTEGER Pointer AS INTEGER END TYPE OPTION BASE 1 COMMON SHARED index() AS indexrecord, Temp() AS indexrecord '$DYNAMIC DIM SHARED names AS address, Temps$(14), choice%, M$(7), np%, prn$(3), yn$ DIM SHARED numberofrecords%, recordnumber%, counter%, found.deleted% DIM SHARED temprow%, comma$, Target$, FGColr, BGColr% ' , nf%, nb%, rf%, rb% DIM SHARED NDXfile$, DATfile$ DIM attr AS FileAttributesType comma$ = CHR$(44) + CHR$(32) ON ERROR GOTO errorhandler DIM Para$(3) DIM parameter$(3) ComLine$ = COMMAND$ FOR FindSlant% = 1 TO LEN(ComLine$) Slant$ = MID$(ComLine$, FindSlant%, 1) IF Slant$ = "/" THEN ParaNum% = ParaNum% + 1 Para$(ParaNum%) = STR$(FindSlant%) IF ParaNum% = 3 THEN EXIT FOR END IF END IF NEXT IF ParaNum% = 0 THEN NDXfile$ = "CIDmenu.men" DATfile$ = "CIDdata.Dat" BGColr% = 1 GOTO top ELSEIF ParaNum% = 1 THEN GOSUB first.para parameter$(1) = First.1$ IF parameter$(1) = "M" THEN NDXfile$ = "CIDmenu.men" DATfile$ = "CIDdata.Dat" BGColr% = 0 GOTO top END IF ELSEIF ParaNum% = 2 THEN GOSUB second.para parameter$(1) = First.1$ parameter$(2) = Second.2$ ELSEIF ParaNum% = 3 THEN GOSUB third.para parameter$(1) = First.1$ parameter$(2) = Second.2$ parameter$(3) = Third.3$ END IF IF LEN(parameter$(1)) > 1 AND LEN(parameter$(2)) = 1 AND LEN(parameter$(3)) = 0 THEN IF parameter$(2) = "M" THEN '1st parameter not M. 2nd NDXfile$ = parameter$(1) 'parameter probably M. GOSUB get.para BGColr% = 0 ELSEIF parameter$(2) <> "M" THEN NDXfile$ = parameter$(1) GOSUB get.para BGColr% = 1 END IF GOTO top ELSEIF LEN(parameter$(1)) = 1 AND LEN(parameter$(2)) > 1 AND LEN(parameter$(3)) > 1 THEN IF parameter$(1) = "M" THEN BGColr% = 0 END IF NDXfile$ = parameter$(2) DATfile$ = parameter$(3) GOTO top ELSEIF LEN(parameter$(1)) = 1 AND LEN(parameter$(2)) > 1 THEN IF parameter$(1) = "M" THEN BGColr% = 0 END IF NDXfile$ = parameter$(2) GOSUB get.para GOTO top ELSEIF LEN(parameter$(1)) > 1 AND LEN(parameter$(2)) = 1 AND LEN(parameter$(3)) > 1 THEN IF parameter$(2) = "M" THEN BGColr% = 0 END IF NDXfile$ = parameter$(1) DATfile$ = parameter$(3) GOTO top ELSEIF LEN(parameter$(1)) > 1 AND LEN(parameter$(2)) = 0 AND LEN(parameter$(3)) = 0 THEN NDXfile$ = parameter$(1) '1st parameter not M because GOSUB get.para ELSEIF LEN(parameter$(1)) > 1 AND LEN(parameter$(2)) > 1 THEN NDXfile$ = parameter$(1) DATfile$ = parameter$(2) IF LEN(parameter$(3)) = 1 THEN IF parameter$(3) = "M" THEN BGColr% = 0 GOTO top END IF END IF END IF BGColr% = 1 top: IF RIGHT$(NDXfile$, 3) = "DAT" THEN NDXfile$ = LEFT$(NDXfile$, LEN(NDXfile$) - 4) NDXfile$ = NDXfile$ + ".MEN" END IF IF RIGHT$(DATfile$, 3) = "MEN" THEN DATfile$ = LEFT$(DATfile$, LEN(DATfile$) - 4) DATfile$ = DATfile$ + ".DAT" END IF IF NDXfile$ = DATfile$ THEN FOR SpotIt% = 1 TO LEN(DATfile$) Spot$ = MID$(DATfile$, SpotIt%, 1) IF Spot$ = "." THEN DATfile$ = LEFT$(DATfile$, SpotIt% - 1) + ".DAT" GOTO top.again END IF NEXT DATfile$ = DATfile$ + ".DAT" END IF top.again: NameOfFile$ = NDXfile$ GOSUB check.filenames FGColr% = 15 CALL OpenFile CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, ExistNum%) check.filenames: FOR ChekIt% = 1 TO LEN(NameOfFile$) EachChar$ = MID$(NameOfFile$, ChekIt%, 1) IF EachChar$ = "." THEN CountDots% = CountDots% + 1 IF CountDots% > 1 THEN GOTO parameter.error END IF ELSEIF EachChar$ = " " THEN IF ChekIt% > 1 THEN GOTO parameter.error END IF ELSEIF EachChar$ < CHR$(48) AND EachChar$ > CHR$(90) THEN GOTO parameter.error END IF NEXT CountTimes% = CountTimes% + 1 IF CountTimes% = 1 THEN NameOfFile$ = DATfile$ CountDots% = 0 GOTO check.filenames ELSEIF CountTimes% >= 2 THEN RETURN END IF first.para: First.1$ = RIGHT$(ComLine$, LEN(ComLine$) - 1) IF VAL(Para$(2)) = 0 THEN RETURN END IF First.1$ = LEFT$(First.1$, VAL(Para$(2)) - 2) First.1$ = RTRIM$(LTRIM$(First.1$)) First.1$ = LEFT$(First.1$, 12) RETURN second.para: GOSUB first.para IF LEN(Para$(3)) > 0 THEN Second.2$ = MID$(ComLine$, VAL(Para$(2)) + 1, VAL(Para$(3)) - VAL(Para$(2)) - 1) '10 Second.2$ = RTRIM$(LTRIM$(Second.2$)) Second.2$ = LEFT$(Second.2$, 12) ELSE Second.2$ = MID$(ComLine$, VAL(Para$(2)) + 1, LEN(ComLine$)) Second.2$ = RTRIM$(LTRIM$(Second.2$)) Second.2$ = LEFT$(Second.2$, 12) END IF RETURN third.para: GOSUB first.para GOSUB second.para Third.3$ = RIGHT$(ComLine$, LEN(ComLine$) - (VAL(Para$(3)))) Third.3$ = RTRIM$(LTRIM$(Third.3$)) RETURN get.para: IF RIGHT$(NDXfile$, 3) = "DAT" THEN DATfile$ = NDXfile$ FOR SpaceCadet% = 1 TO LEN(NDXfile$) FindDot$ = MID$(NDXfile$, SpaceCadet%, 1) IF FindDot$ = "." THEN NDXfile$ = LEFT$(NDXfile$, SpaceCadet%) NDXfile$ = NDXfile$ + "MEN" EXIT FOR END IF NEXT RETURN END IF FOR Measure1% = 1 TO LEN(NDXfile$) 'greater then 1 - make Dot$ = MID$(NDXfile$, Measure1%, 1) 'NDXfile$ = parameter$(1) & IF Dot$ = "." THEN 'DATfile$ = parameter$(1) 'with .DAT extension. 'No M (monochrome here) FoundDot$ = MID$(NDXfile$, 1, Measure1% - 1) + ".DAT" DATfile$ = FoundDot$ EXIT FOR END IF NEXT IF LEN(FoundDot$) = 0 THEN DATfile$ = RTRIM$(LTRIM$(NDXfile$)) + ".DAT" END IF RETURN errorhandler: IF ERR = 53 THEN COLOR 30, 0: CLS LOCATE 10, 30: PRINT "Loading..." CALL DB.Index RESUME top END IF CALL DB.Index GOSUB error.codes IF BGColr% = 0 THEN ErrBG% = 0 ELSEIF BGColr% = 1 THEN ErrBG% = 4 END IF COLOR 15, ErrBG% CALL BoxBoy("<<>>", 6, 16, 13, 62, 7, 35, 11, ErrBG%, 15, ErrBG%, 2, 0, 0, 1) IF BGColr% = 0 THEN COLOR 12, 0 ELSEIF BGColr% = 1 THEN COLOR 14, 4 END IF CALL OneLine(11, 17, 15, ErrBG%, 4, 46) COLOR 15, ErrBG% IF ERR = 55 THEN LOCATE 9, 29: PRINT "File Does Not Exist."; ELSE ErrMessage$ = "Error #" + RTRIM$(LTRIM$(STR$(ERR))) + ". " + E$ + "." LenErrM% = LEN(ErrMessage$) LOCATE 9, 40 - LenErrM% \ 2 + 1: PRINT ErrMessage$; END IF LOCATE 12, 28: COLOR 11, ErrBG%: PRINT ""; COLOR 15, ErrBG% LOCATE 12, 28: PRINT "<"; LOCATE 12, 50: PRINT ">"; SOUND 200, 2 DO: LOOP WHILE INKEY$ = "" COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END END error.codes: IF ERR = 4 THEN E$ = "Out of data" ELSEIF ERR = 5 THEN E$ = "Illegal function call" ELSEIF ERR = 7 THEN E$ = "Out of memory" ELSEIF ERR = 9 THEN E$ = "Subscript out of range" ELSEIF ERR = 14 THEN E$ = "Out of string space" ELSEIF ERR = 16 THEN E$ = "String formula too complex" ELSEIF ERR = 25 THEN E$ = "Device fault" ELSEIF ERR = 27 THEN E$ = "Out of paper" ELSEIF ERR = 52 THEN E$ = "Bad file number" ELSEIF ERR = 53 THEN E$ = "File not found" ELSEIF ERR = 54 THEN E$ = "Bad file mode" ELSEIF ERR = 55 THEN E$ = "File already open" ELSEIF ERR = 57 THEN E$ = "Device In/Out error" ELSEIF ERR = 58 THEN E$ = "File/Path already exists" ELSEIF ERR = 61 THEN E$ = "Disk full" ELSEIF ERR = 62 THEN E$ = "Input past end" ELSEIF ERR = 64 THEN E$ = "Bad file name" ELSEIF ERR = 67 THEN E$ = "Too many lines" ELSEIF ERR = 68 THEN E$ = "Device unavailable" ELSEIF ERR = 70 THEN E$ = "Permission denied" ELSEIF ERR = 71 THEN E$ = "Disk not ready" ELSEIF ERR = 72 THEN E$ = "Disk media error" ELSEIF ERR = 75 THEN E$ = "Bad File/Path access" ELSEIF ERR = 76 THEN E$ = "Path not found" ELSEIF ERR = 77 THEN E$ = "Invalid drive specs" ELSEIF ERR = 79 THEN E$ = "Bad FAT table area" ELSEIF ERR = 80 THEN E$ = "Invalid time data" ELSEIF ERR = 81 THEN E$ = "Invalid time data" ELSEIF ERR = 82 THEN E$ = "Invalid parameter" ELSEIF ERR = 83 THEN E$ = "Buffer too small" ELSEIF ERR = 84 THEN E$ = "Current directory renamed" ELSEIF ERR = 85 THEN E$ = "Lock conflict" ELSEIF ERR = 86 THEN E$ = "Sharing conflict" ELSEIF ERR = 87 THEN E$ = "Read-only conflict" ELSEIF ERR = 100 THEN E$ = "Insufficient elements" ELSEIF ERR = 125 THEN E$ = "Overflow" ELSEIF ERR = 126 THEN E$ = "Out of stack space" ELSEIF ERR = 127 THEN E$ = "Undefined error" ELSE E$ = "Unspecified error" END IF RETURN parameter.error: ON ERROR GOTO errorhandler COLOR 12, 0: CLS PRINT " ÉÍÍÍÍÍÍÍÍÍÍÍÍÍ»" PRINT " º <<>> º" PRINT " ÈÍÍÍÍÍÍÍÍÍÍÍÍͼ" COLOR 10, 0 CALL BoxBoy("", 1, 18, 20, 63, 1, 1, 1, 1, 10, 0, 2, 0, 0, 0) COLOR 15, 0 LOCATE 2, 21: PRINT "Parameter Error! Correct usage:"; LOCATE 3, 21: PRINT " CID /CIDmenu.men /CIDdata.Dat"; LOCATE 4, 18: COLOR 10, 0: PRINT "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ"; COLOR 15, 0 LOCATE 5, 21: PRINT "DOS RULES : Use 1-8 letters/characters "; LOCATE 6, 21: PRINT "in the first section, followed by a dot, "; LOCATE 7, 21: PRINT "& 1-3 letters/characters in the extension."; LOCATE 8, 21: PRINT "The dot and the extension may be omitted. "; LOCATE 9, 21: PRINT "Write 2 parameters. See the above examples."; LOCATE 10, 18: COLOR 10, 0: PRINT "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ"; LOCATE 11, 21: COLOR 15, 0: PRINT "OTHER ERRORS: "; LOCATE 12, 21: PRINT "(1) Must place the two parameters after a "; LOCATE 13, 21: PRINT " slash mark (/). See above. "; LOCATE 14, 21: PRINT "(2) Must have two files, one for the menu, "; LOCATE 15, 21: PRINT " another for the data. "; LOCATE 16, 21: PRINT "(3) May NOT use the same name for both! "; LOCATE 17, 18: COLOR 10, 0: PRINT "ÇÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄĶ"; LOCATE 18, 25: COLOR 15, 0: PRINT "Press to read CID.DOC or"; LOCATE 19, 25: PRINT " press to exit. "; COLOR 10, 0 LOCATE 18, 32: PRINT "Enter"; LOCATE 19, 37: PRINT "Esc"; CALL Noise DO CALL CviCall(HitKey%) IF HitKey% = 13 THEN 'enter CALL GetFileAttributes("CID.Doc", attr) IF attr.result > 0 THEN GOTO print.para.error END IF CALL GetFileAttributes("showoff.Exe", attr) IF attr.result > 0 THEN GOTO print.para.error END IF SHELL "showoff.exe" + " " + "cid.doc" + " /m" GOTO leave ELSEIF HitKey% = 27 THEN GOTO leave END IF LOOP leave: COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END print.para.error: CALL BoxBoy("", 5, 20, 11, 62, 1, 1, 1, 1, 12, 0, 1, 0, 0, 0) LOCATE 6, 22: COLOR 15, 0 PRINT "Either the text browser, ShowOff.Exe,"; LOCATE 7, 22 PRINT "or the documentation file, AddBook.Doc,"; LOCATE 8, 22 PRINT "is missing. Sorry!"; LOCATE 9, 20: COLOR 12, 0 PRINT "Ã" + STRING$(41, "Ä") + "´"; LOCATE 10, 29: COLOR 15, 0 PRINT "- Press Any Key To Exit -"; CALL Noise DO: LOOP WHILE INKEY$ = "" COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END ' +---------------------------------------------------------------------+ ' | | ' | DATABASE.DOC | ' | | ' +---------------------------------------------------------------------+ ' | I have included the document DATABASE.DOC because Mr.Jose Gracia | ' | requested that if any programmer used any of his code, they should | ' | include any comments. I not only retained the comments which | ' | accompany his SUBs and FUNCTIONs, but also this document. | ' +---------------------------------------------------------------------+ ' | DATABASE.BAS | ' | MicroComputer Services | ' | Jose Garcia | ' | PO Box 580 Dauphin, PA 17018 | ' | (717)921-8764 | ' | CIS user number 71211,124 | ' | | ' | | ' | DATABASE.BAS is a simple name/address database program to | ' | demonstrate the text entry, record selection (by means of a | ' | bounce bar) and index routines that I have written. It was | ' | written with version 4.5 but will run in version 4.0 as well. | ' | QuickBASIC MUST BE STARTED WITH THE /AH PARAMETER - in other | ' | words for this program to work properly you MUST start QuickBASIC | ' | by typing QB /AH (more on this later). Any of the code can be | ' | used by other programmers but I ask that the comments be left | ' | intact. The program creates a database record file, names.dat | ' | and an index file, names.ndx in the default directory. If you | ' | have questions, comments or improvements concerning the code | ' | please drop me a line - either U.S. mail or CIS. I will reply | ' | as soon as my schedule permits. | ' | | ' | I originally wrote DATABASE.BAS to demonstrate the txt.edit | ' | routine that I had written. As I started DATABASE.BAS I realized | ' | that I needed a program that would emulate some common dBASE | ' | procedures. Thus, DATABASE.BAS grew to it's present size. It | ' | is not perfect and I hope that programmers who download this | ' | file will improve the coding and let me know the improvements | ' | made to the routines contained in DATABASE.BAS. | ' | | ' | The comments in the coding should help to explain what is | ' | happening and I will add to that now. To begin with, the | ' | TXT.EDIT routine is completely generic and can be used in | ' | other programs or compiled and used from within a QB library. | ' | All that needs to be done is to dimension a temporary array | ' | to hold the fields declared in the TYPE statement, make each | ' | element in the array represent one of those fields. Then call | ' | TXT.EDIT (arrayname), (starting screen row), (starting screen | ' | column), (flag, - 0 or 1, where 0 is overtype mode and 1 is | ' | insert mode). The routine will continue until all array | ' | elements (fields) have entries or 's. Then the array | ' | elements are switched back to the TYPE variables to be used | ' | by the rest of the program. | ' | | ' | The GETNAME routine can be used in other programs if the screen | ' | locations (LOCATE) are changed to accommodate your program and | ' | the TYPE variables are changed to your names. BORDER, HIGHLIGHT, | ' | LOWLIGHT, PAUSE and BOX routines will have to be included. It | ' | allows the user to choose a record entry easily by using the | ' | arrow keys, highlighting the record desired and pressing . | ' | It eliminates the errors caused by users having to type in the | ' | names of record entries and making typographical errors. | ' | | ' | The DB.INDEX routine called in the ON ERROR routine is used if | ' | the database file contains records but the index file is missing. | ' | It can be used to restore a corrupted index file or to build an | ' | new index file using the records contained in the data base. Note: | ' | it only works with database files created by QuickBASIC programs, | ' | it will not work with Ashton-Tate's dBASE version database files | ' | (.DBF). Your code will have to be changed to use your TYPE'd | ' | variable names, database record filename and your index filename | ' | in the DB.INDEX, OPENINDEX, REINDEX and UPDATENDX routines. The | ' | index file is read and entered into a dynamic array at the start | ' | of the program. All updates to the index are made to the memory | ' | array and are not written to file until the program exits normally | ' | (by using 5 at the main menu or arrowing down to QUIT and pressing | ' | . NOTE:If records are added to the database record file | ' | while running in the QuickBASIC environment and you "BREAK" | ' | out of the program instead of QUITing with choice 5 on the | ' | menu, the index file will not be updated and you will get an error | ' | the next time you run the program. Always QUIT the program through | ' | the menu. Else DEL NAMES.NDX to fix. The new index is then written| ' | to disk and will be ready for the next session. The index array is | ' | stored dynamically in the far heap and outside of the 64K BASIC | ' | boundary for variables (DGROUP) so that arrays larger than 64K can | ' | be used (this would happen in large commercial applications). To | ' | ensure correct operation of the DB.INDEX, OPENINDEX, REINDEX and | ' | UPDATENDX routines, QB MUST be started with QB /AH. Also, use | ' | the /AH switch when compling from the command line with BC. | ' | | ' | The menu routine is "borrowed" from Frank Neal, it is a popular | ' | menu bounce-bar routine. For it to work, the variables choice% | ' | and np% MUST be dimensioned as shared with a DIM SHARED choice%, | ' | np% statement. Where choice% is the variable that returns the | ' | users menu choice and np% is the variable that contains the number | ' | of menu choices, also the number of elements in the array m$ should | ' | be dimensioned, but is not necessary. | ' | | ' | The DELETE routine is of interest because of the method used in | ' | deleting records. When a record is deleted, the DELETE routine | ' | simply adds an ASCII 20 (the paragraph symbol) as the first | ' | character in the field being indexed. When records are displayed, | ' | any record beginning with an ASCII 20 is simply skipped. When | ' | new records are added, the DATAENTRY routine after getting a new | ' | entry but before it is added to the database record file looks in | ' | the index to see if there is an entry that starts with an ASCII 20. | ' | If there is such an entry, the new record is saved with the record | ' | number of the record containing the ASCII 20, thus overwriting it | ' | and finally physically deleting it from the database file and index.| ' | | ' | The REINDEX, SEARCH%, NOSPACE$ and SORT routines were implemented | ' | from routines contained in the book Microsoft QuickBASIC Second | ' | Edition by Douglas Hergert. The SORT routine is a shell sort. The | ' | SEARCH% function is a binary search. The NOSPACE$ function | ' | removes any spaces in the index record of the fields names.first | ' | and names.last. The REINDEX routine simply adds a new entry to | ' | the index array in memory. | ' | | ' | I would appreciate any comments or improvements concerning this | ' | code. It did take me some time and effort to get the routines | ' | "up and running" so please take the time to contact me. | ' | | ' | Enjoy, | ' | Jose Garcia | ' | | ' +---------------------------------------------------------------------+ REM $STATIC SUB BigBox (RowUL%, ColUL%, RowLR%, ColLR%, ColrFG%, ColrBG%) ' +--------------------------[SUB BigBox]-------------------------------+ ' | This SUB makes a box, but doesn't clear the box it makes. | ' | Public Domain FreeWare by Don Smith. Date: 01/01/2003. | ' | EMail: smithdonb@earthlink.net | ' +---------+-----------------------------------------------------------+ ' | RowUL% | Upper left row to begin box. | ' +---------+-----------------------------------------------------------+ ' | ColUL% | Upper left column to begin box. | ' +---------+-----------------------------------------------------------+ ' | RowLR% | Lower right row to begin box. | ' +---------+-----------------------------------------------------------+ ' | ColLR% | Lower right column to begin box. | ' +---------+-----------------------------------------------------------+ ' | ColrFG% | Foreground color of box. | ' +---------+-----------------------------------------------------------+ ' | ColrBG% | Background color of box. | ' +---------+-----------------------------------------------------------+ COLOR ColrFG%, ColrBG% LOCATE RowUL%, ColUL% PRINT CHR$(201) + STRING$(ColLR% - ColUL% - 1, CHR$(205)) + CHR$(187); FOR All1% = (RowUL% + 1) TO (RowLR% - 1) LOCATE All1%, ColUL% PRINT CHR$(186); NEXT FOR All2% = (RowUL% + 1) TO (RowLR% - 1) LOCATE All2%, ColLR% PRINT CHR$(186); NEXT LOCATE RowLR%, ColUL% PRINT CHR$(200) + STRING$(ColLR% - ColUL% - 1, CHR$(205)) + CHR$(188); END SUB REM $DYNAMIC SUB BoxBoy (Title$, ULRow%, ULCol%, LRRow%, LRCol%, TitleRow%, TitleCol%, TitColrFG%, TitColrBG%, BoxColrFG%, BoxColrBG%, BoxStyle%, Shadow%, ShadowColr%, EdgeYN%) ' +--------------------------------------------------------------------+ ' | | ' | SUB BoxBoy | ' | | ' +--------------------------------------------------------------------+ ' | The SUB BoxBoy was written by Don Smith. This BoxBoy is the | ' | lastest iteration of the SUB - written 12-01-2002. Other | ' | programmers, or anyone else for that matter, may use this SUB | ' | without naming me as the author, and they may modify the code | ' | in any way they see fit. | ' | | ' | Don's EMail: smithdonb@earthlink.net | ' | | ' | This SUB only saves that portion of the underlying screen under | ' | the box and repaints with a shadow. So recommend using the SUB | ' | SaveRestScrn to save/restore the complete screen, or a larger | ' | portion of the screen than the box. | ' +-------------+------------------------------------------------------+ ' | Title$ | The title of the menu. To make a box without a title,| ' | | use: Title$ = "". When there is no Title, the cross | ' | | bar is not deployed. | ' +-------------+------------------------------------------------------+ ' | ULRow% | The upper left row to place the box. | ' +-------------+------------------------------------------------------+ ' | ULCol% | The upper left column to place the box. | ' +-------------+------------------------------------------------------+ ' | LRRow% | The lower right row to place the box. | ' +-------------+------------------------------------------------------+ ' | LRCol% | The lower right column to place the box. | ' +-------------+----------------------------------+-------------------+ ' | TitleRow% | The row to place the title. | If Title$ = "" | ' +-------------+----------------------------------| (or NO title), | ' | TitleCol% | The column to place the title. | report these four | ' +-------------+----------------------------------| values as zero (0)| ' | TitColrFG% | The foreground color of the title| . . . . . . . . | ' +-------------+----------------------------------| Example -> | ' | TitColrBG% | The background color of the title| TitColrFG% = 0 | ' +-------------+----------------------------------+-------------------+ ' | BoxColrFG% | The foreground color of the box itself. | ' +-------------+------------------------------------------------------+ ' | BoxColrBG% | The back ground color of the box. | ' +-------------+------------------------------------------------------+ ' | BoxStyle% | BoxStyle% = 0 (No line around box) | ' | | BoxStyle% = 1 (Single line around box | ' | | BoxStyle% = 2 (Double line around box | ' | | BoxStyle% = 3 (Solid line around box | ' +-------------+------------------------------------------------------+ ' | Shadow% | If Shadow% equals 0, there will be no shadow. | ' | | If Shadow% equals 1, there will be a right shadow. | ' | | If Shadow% equals 2, there will be a left shadow | ' | +------------------------------------------------------+ ' | | NOTE #1: | ' | | ------- | ' | | When a shadow is used, the underlying text will | ' | | be saved and printed with the ShadeColr% (just | ' | | below). This causes the shadow to look like a | ' | | real shadow. | ' | | | ' | | NOTE #2: | ' | | ------- | ' | | If the first four values of BoxBoy are 1, 1, 25, 80, | ' | | in other words a full screen, please set Shadow% = 0;| ' | | otherwise an error will result (no room for shadow). | ' +-------------+------------------------------------------------------+ ' | ShadowColr% | The ShadowColr% is the foreground color of the | ' | | shadow. The background color will always be | ' | | black. Either choose ShadowColr% = 7 or | ' | | ShadowColr% = 8. | ' | | | ' | | ShadowColr% = 7 saves the foreground color and | ' | | changes it to a shade darker, if possible. For | ' | | example, a bright white on blue (COLOR 15, 1) | ' | | becomes dim white on black (COLOR 7, 0). A bright | ' | | blue on blue (COLOR 9, 1) becomes regular blue | ' | | on black (COLOR 1, 0). Very realistic. | ' | | | ' | | ShadowColr% = 8 saves the foreground and reprints | ' | | it as COLOR 8, 0. Darker then ShadowColr% = 7 | ' +-------------+----------------+-------------------------------------+ ' | EdgeYN% | EdgeYN% = 0 | Do NOT print an edge of one space | ' | | | with BoxColrFG% color on the right | ' | | | and left edges of the box. | ' | +----------------+-------------------------------------+ ' | | EdgeYN% = 1 | YES, DO print an edge of one space | ' | | | with BoxColrFG% color on the right | ' | | | and left edges of the box. | ' | +----------------+-------------------------------------+ ' | | What does it mean to "print an edge of one space | ' | | with BoxColrFG% color on the right and left edges | ' | | of the box". Well, I will attempt to demonstrate | ' | | by drawing the boxes with non-extended ASCII | ' | | characters. The X's represent a shadow to the | ' | | right. | ' | | | ' | | NO EDGE RIGHT/LEFT 1 SPACE EDGE RIGHT/LEFT | ' | | ~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~ | ' | | (EdgeYN% = 0) (EdgeYN% = 1 | ' | | | ' | | +-----------------+ +-------------------+ | ' | | |+---------------+| | +---------------+ | | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | || ||XX | | | |XX | ' | | |+---------------+|XX | +---------------+ |XX | ' | | +-----------------+XX +-------------------+XX | ' | | XXXXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXX | ' | | | ' +-------------+------------------------------------------------------+ IF Title$ = "" THEN TitleRow% = 1: TitleCol% = 1: TitColrFG% = 1: TitColrBG% = 1 END IF IF EdgeYN% > 1 OR EdgYN% < 0 THEN EdgeYN% = 0 END IF IF ULCol% <= 1 THEN ULCol% = 1 END IF IF LRCol% = 80 THEN LRCol% = 79 END IF make.box: IF BoxStyle% = 0 THEN 'No Lines ULCorner$ = CHR$(255) URCorner$ = CHR$(255) HorLineTop$ = CHR$(255) HorLineBot$ = CHR$(255) LeftSide$ = CHR$(255) RightSide$ = CHR$(255) VertLine$ = CHR$(255) LLCorner$ = CHR$(255) LRCorner$ = CHR$(255) ELSEIF BoxStyle% = 1 THEN 'Single Line ULCorner$ = CHR$(218) URCorner$ = CHR$(191) HorLineTop$ = CHR$(196) HorLineBot$ = CHR$(196) LeftSide$ = CHR$(195) RightSide$ = CHR$(180) VertLine$ = CHR$(179) LLCorner$ = CHR$(192) LRCorner$ = CHR$(217) ELSEIF BoxStyle% = 2 THEN 'Double Line ULCorner$ = CHR$(201) URCorner$ = CHR$(187) HorLineTop$ = CHR$(205) HorLineBot$ = CHR$(205) LeftSide$ = CHR$(199) RightSide$ = CHR$(182) VertLine$ = CHR$(186) LLCorner$ = CHR$(200) LRCorner$ = CHR$(188) ELSEIF BoxStyle% = 3 THEN 'Solid line ULCorner$ = CHR$(219) URCorner$ = CHR$(219) HorLineTop$ = CHR$(223) HorLineBot$ = CHR$(220) LeftSide$ = CHR$(219) RightSide$ = CHR$(219) VertLine$ = CHR$(219) LLCorner$ = CHR$(219) LRCorner$ = CHR$(219) END IF IF Shadow% > 0 THEN IF EdgeYN% = 1 THEN IF Shadow% = 1 THEN LeftLimit% = ULCol% + 2 RightLimit% = LRCol% + 5 ELSEIF Shadow% = 2 THEN LeftLimit% = ULCol% - 2 RightLimit% = LRCol% END IF ELSEIF EdgeYN% = 0 THEN IF Shadow% = 1 THEN LeftLimit% = ULCol% + 2 RightLimit% = LRCol% + 3 ELSEIF Shadow% = 2 THEN LeftLimit% = ULCol% - 2 RightLimit% = LRCol% - 1 END IF END IF REDIM ReadLine$(25): REDIM ReadColr%(25, 80) FOR ViewIt% = ULRow% + 1 TO LRRow% + 1 FOR Horizon% = LeftLimit% TO RightLimit% ReadLine$(ViewIt%) = ReadLine$(ViewIt%) + CHR$(SCREEN(ViewIt%, Horizon%)) ReadColr%(ViewIt%, Horizon%) = SCREEN(ViewIt%, Horizon%, 1) NEXT NEXT FOR FindRow% = ULRow% + 1 TO LRRow% + 1 FOR ScrnCol% = LeftLimit% TO RightLimit% LOCATE FindRow%, ScrnCol%, 0 OneColr% = ReadColr%(FindRow%, ScrnCol%) FGScrnColr% = OneColr% MOD 16 'make colors less bright IF FGScrnColr% = 0 THEN FGScrnColr% = 7 IF FGScrnColr% = 9 THEN FGScrnColr% = 1 IF FGScrnColr% = 10 THEN FGScrnColr% = 2 IF FGScrnColr% = 11 THEN FGScrnColr% = 3 IF FGScrnColr% = 12 THEN FGScrnColr% = 4 IF FGScrnColr% = 13 THEN FGScrnColr% = 5 IF FGScrnColr% = 14 THEN FGScrnColr% = 7 IF FGScrnColr% = 15 THEN FGScrnColr% = 7 BGScrnColr% = OneColr% \ 16 IF ShadowColr% = 7 THEN COLOR FGScrnColr%, 0 ELSEIF ShadowColr% = 8 THEN COLOR 8, 0 END IF IF Shadow% = 1 THEN PRINT MID$(ReadLine$(FindRow%), ScrnCol% - (ULCol% + 1)); ELSEIF Shadow% = 2 THEN PRINT MID$(ReadLine$(FindRow%), ScrnCol% - (ULCol% - 3)); END IF NEXT NEXT ERASE ReadLine$: ERASE ReadColr% END IF IF EdgeYN% = 1 THEN Edge$ = " " END IF Title.Length% = LEN(Title$) COLOR BoxColrFG%, BoxColrBG% 'ÚÄÄÄ¿ or ÉÍÍÍ» LOCATE ULRow%, ULCol%, 0 PRINT Edge$ + ULCorner$ + STRING$(LRCol% - ULCol%, HorLineTop$) + URCorner$ + Edge$; '³ ³ or º º LOCATE ULRow% + 1, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; IF Title$ <> "" THEN 'ÃÄÄÄ´ or ÇÄÄĶ 'made cross bar if there is a title LOCATE ULRow% + 2, ULCol%, 0 PRINT Edge$ + LeftSide$ + STRING$(LRCol% - ULCol%, 196) + RightSide$ + Edge$; ELSEIF Title$ = "" THEN LOCATE ULRow% + 2, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; END IF '³ ³ or º º FOR Print.Box% = 1 TO (LRRow% - ULRow%) - 3 LOCATE ULRow% + Print.Box% + 2, ULCol%, 0 PRINT Edge$ + VertLine$ + SPACE$(LRCol% - ULCol%) + VertLine$ + Edge$; NEXT 'ÀÄÄÄÙ or ÈÍÍͼ LOCATE LRRow%, ULCol%, 0 PRINT Edge$ + LLCorner$ + STRING$(LRCol% - ULCol%, HorLineBot$) + LRCorner$ + Edge$; IF Title$ <> "" THEN LOCATE TitleRow%, TitleCol%, 0 COLOR TitColrFG%, TitColrBG% PRINT Title$; END IF END SUB REM $STATIC SUB CheckStatus (Trial%, NDXfile$, DATfile$, ErrExist%) STATIC '+----------------------------------------------------------------------+ '| SUB CheckStatus | '| | '| Public Domain - FreeWare | '+---------+------------------------------------------------------------+ '|Trial% | Number to associate with a particular file | '| | to check its existence. | '| | | '| | Trial% = 1 : check if CID.Txt exists. ErrExist% = 1 | '| | Trial% = 2 : check if ShowOff.Exe exists. ErrExist% = 2 | '| | Trial% = 3 : check if PrintIt.Exe exists. ErrExist% = 3 | '| | Trial% = 4 : check if NDXfile$ exists. ErrExist% = 4 | '| | Trial% = 5 : check if DATfile$ exists. ErrExist% = 5 | '| | Trial% = 6 : check if PrintDoc.Exe exists. ErrExist% = 6 | '| | Trial% = 7 : check if CIDPrint.Txt exists. ErrExist% = 7 | '+---------+------------------------------------------------------------+ '|NDXfile$ | The NDXfile file is "CIDmenu.men" and displays the menu. | '+---------+------------------------------------------------------------+ '|DATfile$ | The DATfile$ file is "CIDdata.Dat" and contains the data | '| | for each of the customers names. | '+---------+------------------------------------------------------------+ '|ErrExist%| If a particular file does not exists, reports the | '| | number, to wit: | '| | | '| | +----------------+-------------------+ | '| | | ErrExist% # | Doesn't Exist: | | '| | +----------------+-------------------+ | '| | | ErrExist% = 1 | CID.Txt | | '| | | ErrExist% = 2 | ShowOff.Exe | | '| | | ErrExist% = 3 | PrintIt.Exe | | '| | | ErrExist% = 4 | MyMenu.Dat | | '| | | ErrExist% = 5 | MyDate.Dat | | '| | | ErrExist% = 6 | PrintDoc.Exe | | '| | | ErrExist% = 7 | CIDPrint.Txt | | '| | +----------------+-------------------+ | '+---------+------------------------------------------------------------+ DIM attr AS FileAttributesType IF Trial% = 1 THEN CALL GetFileAttributes("cid.txt", attr) IF attr.result > 0 THEN Message1$ = "CID.Txt" GOSUB show.error ErrExist% = 1 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 2 THEN CALL GetFileAttributes("showoff.exe", attr) IF attr.result > 0 THEN Message1$ = "ShowOff.Exe" GOSUB show.error ErrExist% = 2 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 3 THEN CALL GetFileAttributes("PrintIt.Exe", attr) IF attr.result > 0 THEN Message1$ = "PrintIt.Exe" ErrExist% = 3 EXIT SUB END IF ELSEIF Trial% = 4 THEN CALL GetFileAttributes(NDXfile$, attr) IF attr.result > 0 THEN Message1$ = NDXfile$ GOSUB show.error ErrExist% = 4 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 5 THEN CALL GetFileAttributes(DATfile$, attr) IF attr.result > 0 THEN Message1$ = DATfile$ GOSUB show.error ErrExist% = 5 DO: LOOP UNTIL INKEY$ = CHR$(27) EXIT SUB END IF ELSEIF Trial% = 6 THEN CALL GetFileAttributes("PrintDoc.Exe", attr) IF attr.result > 0 THEN Message1$ = "PrintDoc.Exe" ErrExist% = 6 EXIT SUB END IF ELSEIF Trial% = 7 THEN CALL GetFileAttributes("CIDPrint.Txt", attr) IF attr.result > 0 THEN Message1$ = "CIDPrint.Txt" ErrExist% = 7 EXIT SUB END IF ELSE EXIT SUB END IF EXIT SUB show.error: IF BGColr% = 0 THEN StatusFG% = 15: StatusBG% = 0 ELSEIF BGColr% = 1 THEN StatusFG% = 15: StatusBG% = 4 END IF CALL BoxBoy("", 17, 22, 23, 56, 1, 1, 1, 1, StatusFG%, StatusBG%, 2, 0, 0, 0) CALL OneLine(19, 22, StatusFG%, StatusBG%, 4, 34) LOCATE 18, 33: COLOR 11, StatusBG%: PRINT "<<< ERROR >>>"; MidPt% = LEN("Unable To Find: " + Message1$) MidPt% = 40 - (MidPt% \ 2) LOCATE 20, 26: COLOR StatusFG%, StatusBG% PRINT "Unable To Find: " + Message1$; LOCATE 20, 42: COLOR 14, StatusBG%: PRINT Message1$ CALL OneLine(21, 22, StatusFG%, StatusBG%, 4, 34) LOCATE 22, 29: PRINT "Press To Continue"; LOCATE 22, 36, 0, 0, 0: COLOR 11, StatusBG%: PRINT "ESC"; SOUND 150, 2 RETURN END SUB SUB CviCall (HitKey%) DO HitKey$ = INKEY$ LOOP UNTIL LEN(HitKey$) > 0 HitKey% = CVI(HitKey$ + CHR$(0)) END SUB SUB dataentry (FGColr%, BGColr%) ' +----------------------------------------------------------------------+ ' | The TYPE variables are assigned to the array temps$(), txt.edit is | ' | called for data entry, then the temporary array variables are | ' | switched back to their TYPE'd names. The search% function sees if | ' | the record is already in the index memory array. The finddeleted% | ' | function checks for a deleted record and dataentry will put the new | ' | record into the database record file with the deleted record's | ' | record number, thus deleting the deleted record physically from the | ' | file. See comments in DELETE sub. | ' +----------------------------------------------------------------------+ CALL form(FGColr%, BGColr%) 'COLOR 14, 0: LOCATE 2, 66: PRINT "Insert Off"; Temps$(1) = names.last Temps$(2) = names.first Temps$(3) = names.address Temps$(4) = names.city Temps$(5) = names.state Temps$(6) = names.zip Temps$(7) = names.phone Temps$(8) = names.ssnum Temps$(9) = names.dob Temps$(10) = names.comments1 Temps$(11) = names.comments2 Temps$(12) = names.comments3 Temps$(13) = names.comments4 Temps$(14) = names.comments5 try.again: IF BGColr% = 0 THEN BoxFG% = 12 BoxBG% = 0 ELSEIF BGColr% = 1 THEN BoxFG% = 15 BoxBG% = 4 END IF CALL Txt.Edit(Temps$(), 14, BGColr%) REDIM ReadLine$(25): REDIM ReadColr%(25, 80) CALL SaveRestScrn(ReadLine$(), ReadColr%(), 1, 1, 25, 80, 1) CALL BoxBoy("", 10, 17, 14, 65, 1, 1, 1, 1, BoxFG%, BoxBG%, 2, 0, 0, 0) IF BGColr% = 1 THEN TempBG% = 4 COLOR FGColr%, TempBG% LOCATE 11, 18, 0: PRINT " Exit Editor & Save Current Values (Y/N)? "; LOCATE 13, 18, 0: PRINT " Press To Exit Without Saving. "; COLOR 11, BoxBG% LOCATE 11, 56, 0: PRINT "Y"; : LOCATE 11, 58, 0: PRINT "N"; LOCATE 13, 31, 0: PRINT "Esc"; CALL OneLine(12, 17, BoxFG%, BoxBG%, 4, 48) correct: ans$ = INPUT$(1) IF ans$ = CHR$(27) THEN EXIT SUB END IF IF UCASE$(ans$) = "Y" THEN recordnumber% = recordnumber% + 1 CALL Switch(recordnumber%) IF LEN(Temps$(1)) = 0 OR LEN(Temps$(1)) = 1 THEN 'A blank line names.last = CHR$(20) + MID$(names.last, 2) ELSEIF LEN(Temps$(2)) = 20 THEN names.first = "(Blank Line)" END IF last$ = names.last first$ = names.first 'Target$ = NoSpace$(last$) + comma$ + NoSpace$(first$) Target$ = RTRIM$(LTRIM$(last$)) + comma$ + RTRIM$(LTRIM$(first$)) IF numberofrecords% <> 0 THEN inFile% = Search%(Target$) END IF IF inFile% > 0 THEN CALL BigBox(10, 17, 14, 66, 12, BGColr%) CALL OneLine(12, 17, 12, BGColr%, 4, 48) COLOR FGColr%, BGColr% LOCATE 11, 18: PRINT " That name is already on file "; LOCATE 13, 18: PRINT " "; DO: LOOP WHILE INKEY$ = "" EXIT SUB END IF found.deleted% = 0 found.deleted% = FindDeleted%(GetNum%) IF found.deleted% THEN numberofrecords% = numberofrecords% - 1 recordnumber% = found.deleted% END IF PUT #1, recordnumber%, names numberofrecords% = numberofrecords% + 1 CALL ReIndex(Target$) CALL updateNDX ELSEIF UCASE$(ans$) = "N" THEN CALL SaveRestScrn(ReadLine$(), ReadColr%(), 1, 1, 25, 80, 2) ERASE ReadLine$: ERASE ReadColr% GOTO try.again ELSE GOTO correct END IF EXIT SUB END SUB SUB DB.Index ' +----------------------------------------------------------------------+ ' | This routine can also be used in programs to reindex an .ndx file | ' | (created with the routines in this program) that has become corrupt. | ' | The database record file has to be intact. | ' +----------------------------------------------------------------------+ CLOSE OPEN DATfile$ FOR RANDOM AS #1 LEN = (LEN(names)) numberofrecords% = LOF(1) \ LEN(names) FOR I% = 1 TO numberofrecords% GET #1, I%, names index(I%).firstlast = UCASE$(LTRIM$(RTRIM$(names.last))) + comma$ + UCASE$(LTRIM$(RTRIM$(names.first))) index(I%).recordnumber = names.recnum NEXT I% CALL Sort CALL updateNDX CLOSE #1 CALL OpenFile END SUB SUB Delete (FGColr%, BGColr%) ' +----------------------------------------------------------------------+ ' | This routine does not physically delete records from the database | ' | record file. Instead, it enters an ASCII 20 character for the first | ' | character of the indexed record and the database record. These | ' | records are overlooked by any routines that display records or | ' | indexes, thus "deleting" them from the files. They are physically | ' | removed when new records are added because they are overwritten by | ' | the new records. | ' +----------------------------------------------------------------------+ IF BGColr% = 0 THEN DelFG% = 12 DelBG% = 0 ELSEIF BGColr% = 1 THEN DelFG% = 15 DelBG% = 4 END IF CALL BigBox(10, 25, 12, 54, DelFG%, DelBG%) CALL BoxBoy("", 10, 25, 12, 54, 0, 0, 0, 0, DelFG%, DelBG%, 2, 0, 0, 0) LOCATE 11, 26: COLOR 15, DelBG%: PRINT " Delete this record (Y/N)? "; COLOR 11, DelBG% LOCATE 11, 47: PRINT "Y"; : LOCATE 11, 49: PRINT "N"; 'CALL YesOrNo CALL CviCall(HitKey%) IF HitKey% = 27 OR HitKey% = 110 OR HitKey% = 78 THEN ' CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) ELSEIF HitKey% = 121 OR HitKey% = 89 THEN ' or names.last = CHR$(20) + MID$(names.last, 2) PUT #1, Temp(counter%).recordnumber, names counter% = Temp(counter%).Pointer index(counter%).firstlast = CHR$(20) + RTRIM$(LTRIM$(MID$(names.last, 2))) + comma$ + RTRIM$(LTRIM$(MID$(names.first, 1))) index(counter%).recordnumber = names.recnum CALL Sort END IF END SUB SUB displaydata (FGColr%, BGColr%) 'FGColr% is the Foreground Color 'BGColr% is the Background Color CALL form(FGColr%, BGColr%) COLOR 11, BGColr% LOCATE 2, 2 PRINT SPACE$(76); LOCATE 2, 23 PRINT "ð CUSTOMER INFORMATION DATABASE ð"; COLOR FGColr%, BGColr% LOCATE 2, 25: PRINT "CUSTOMER INFORMATION DATABASE"; COLOR 14, BGColr% Row% = 4 Col% = 19 LOCATE Row%, Col%: PRINT names.last Row% = 4 Col% = 48 LOCATE Row%, Col%: PRINT names.first Row% = 6 Col% = 12 LOCATE Row%, Col%: PRINT names.address Row% = 8 Col% = 11 LOCATE Row%, Col%: PRINT names.city Row% = 8 Col% = 51 LOCATE Row%, Col%: PRINT names.state Row% = 8 Col% = 64 LOCATE Row%, Col%: PRINT names.zip Row% = 10 Col% = 11 LOCATE Row%, Col%: PRINT names.phone Row% = 12 Col% = 23 LOCATE Row%, Col%: PRINT names.ssnum Row% = 12 Col% = 60 LOCATE Row%, Col%: PRINT names.dob Row% = 15 Col% = 15 LOCATE Row%, Col%: PRINT names.comments1 Row% = 16 Col% = 15 LOCATE Row%, Col%: PRINT names.comments2 Row% = 17 Col% = 15 LOCATE Row%, Col%: PRINT names.comments3 Row% = 18 Col% = 15 LOCATE Row%, Col%: PRINT names.comments4 Row% = 19 Col% = 15 LOCATE Row%, Col%: PRINT names.comments5 LOCATE 22, 8, 0 COLOR 15, BGColr% PRINT "TO CHANGE INFO, PRESS AND SELECT FROM THE MAIN MENU."; COLOR 11, BGColr% LOCATE 22, 31, 0: PRINT "Esc"; : LOCATE 22, 48, 0: PRINT "Edit"; DO DO GoAhead$ = INKEY$ LOOP UNTIL LEN(GoAhead$) > 0 IF GoAhead$ = CHR$(27) THEN EXIT SUB END IF LOOP END SUB SUB Edit (FGColr%, BGColr%) STATIC ' +----------------------------------------------------------------------+ ' | This routine calls txt.edit with the flag% value of 0 which means | ' | that the txt.edit sub starts in the overwrite mode as opposed to | ' | the insert mode that it starts in when flag% is set to 1 in the | ' | dataentry sub. I have not devised a method of checking for double | ' | entry if the first and last name are already on file because if data | ' | other than the names were changed here, the first and last names are | ' | already on file in the original copy of the record and the double | ' | entry check used in the DATAENTRY routine would not work here | ' | because it would always find a double entry. This is a good place | ' | for improvement. | ' +----------------------------------------------------------------------+ CALL form(FGColr%, BGColr%) COLOR 11, BGColr% LOCATE 2, 2 PRINT SPACE$(78); LOCATE 2, 22 PRINT "Please Fill In Any New Information:"; COLOR 14, 1 LOCATE 2, 66: PRINT "Insert Off"; COLOR 14, BGColr% LOCATE 4, 19 PRINT names.last LOCATE 4, 48 PRINT names.first LOCATE 6, 12 PRINT names.address LOCATE 8, 11 PRINT names.city LOCATE 8, 51 PRINT names.state LOCATE 8, 64 PRINT names.zip LOCATE 10, 11 PRINT names.phone LOCATE 12, 23 PRINT names.ssnum LOCATE 12, 60 PRINT names.dob LOCATE 15, 15 PRINT names.comments1 LOCATE 16, 15 PRINT names.comments2 LOCATE 17, 15 PRINT names.comments3 LOCATE 18, 15 PRINT names.comments4 LOCATE 19, 15 PRINT names.comments5 Temps$(1) = names.first Temps$(2) = names.last Temps$(3) = names.address Temps$(4) = names.city Temps$(5) = names.state Temps$(6) = names.zip Temps$(7) = names.phone Temps$(8) = names.ssnum Temps$(9) = names.dob Temps$(10) = names.comments1 Temps$(11) = names.comments2 Temps$(12) = names.comments3 Temps$(13) = names.comments4 Temps$(14) = names.comments5 CALL Txt.Edit(Temps$(), 14, BGColr%) IF BGColr% = 0 THEN BoxFG% = 12 BoxBG% = 0 ELSEIF BGColr% = 1 THEN BoxFG% = 15 BoxBG% = 4 END IF REDIM ReadLine$(25): REDIM ReadColr%(25, 80) CALL SaveRestScrn(ReadLine$(), ReadColr%(), 1, 1, 25, 80, 1) CALL BoxBoy("", 10, 17, 14, 65, 0, 0, 0, 0, BoxFG%, BoxBG%, 2, 0, 0, 0) IF BGColr% = 1 THEN TempBG% = 4 COLOR FGColr%, TempBG% LOCATE 11, 18, 0: PRINT " Exit Editor & Save Current Values (Y/N)? "; LOCATE 13, 18, 0: PRINT " Press To Exit Without Saving. "; COLOR 11, BoxBG% LOCATE 11, 56, 0: PRINT "Y"; : LOCATE 11, 58, 0: PRINT "N"; LOCATE 13, 31, 0: PRINT "Esc"; CALL OneLine(12, 17, BoxFG%, BoxBG%, 4, 48) ans$ = INPUT$(1) IF ans$ = CHR$(27) THEN CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) END IF IF UCASE$(ans$) = "Y" THEN Switch names.recnum% counter% = Temp(counter%).Pointer index(counter%).firstlast = UCASE$(LTRIM$(RTRIM$(names.last))) + comma$ + UCASE$(LTRIM$(RTRIM$(names.first))) PUT #1, names.recnum, names Sort EXIT SUB ELSEIF UCASE$(ans$) = "N" THEN CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) END IF END SUB SUB EditLoco (EdW$, Row%, Col%, FCol%, LenStr%, See%, TypeOfText$, Caps%, FGColr%, BGColr%, FKey$, Ins%, PW%, TabUpDn$, ExitCode%) STATIC ' +--------------------------------------------------------------------+ ' | | ' | - S U B E d i t L o c o - | ' | | ' | Public Domain - FreeWare | ' +--------------------------------------------------------------------+ ' | SUB EditLoco is FreeWare Public Domain software by Don Smith | ' | written on 01/01/2003. For Instructions, see SUB EditLoco. | ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | - ABOUT THE AUTHOR - | ' +--------------------------------------------------------------------+ ' | | ' |Hello. My name is Don Smith and I am a retired Math/History/Spanish | ' |teacher residing in Orange County, California. I am also a former | ' |6-year Sergeant of Marines. Who-Rah! On certain forums I am known | ' |as MarineDon. My email is: smithdonb@earthlink.net | ' | | ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | - COPYING AND DISTIBUTING - | ' +--------------------------------------------------------------------+ ' | Since this code is public domain and freeware, anyone may freely | ' | copy and distribute it. If you use the QuickBasic code in one of | ' | your own programs, you do not have to cite my name as the author, | ' | and you may even change its name. | ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | This is a version of SUB EditString is called SUB EditLoco. The | ' | SUB EditString is compiled with the Pro.Lib from Cresent SoftWare.| ' | This version, called SUB EditLoco is compiled with regular ol' | ' | QuickBASIC v4.5 and needs no special library. | ' +--------------------------------------------------------------------+ ' | EdW$ | The string to be edited. | ' +--------------+-----------------------------------------------------+ ' | Row% | The row to begin the editing. | ' +--------------+-----------------------------------------------------+ ' | Col% | The column to begin the editing. | ' +--------------+-----------------------------------------------------+ ' | FCol% | Use same number as Col% | ' +--------------+-----------------------------------------------------+ ' | LenStr% | Length of the string to edit. | ' +--------------+-----------------------------------------------------+ ' | See% | If See% = 0 then existing text will be displayed. | ' | | If See% = 1 existing text will be wiped. | ' +--------------+-----------------------------------------------------+ ' | TypeOfText$ | For all ASCII characers 32 to 255, TypeOfText = "" | ' | | For numbers only, TypeOfText$ = "1234567890" | ' | | For numbers with commas and decimals points, | ' | | TypeOfText$ = ".,1234567890" | ' | | For Yes or No answers, TypeOfText$ = "YNyn" | ' | | Whatever is included within the parethesis | ' | | is what will be accepted. | ' +--------------+-----------------------------------------------------+ ' | Caps% | Capital letters enabled, Caps% = 1 | ' +--------------+-----------------------------------------------------+ ' | FGColr% | The text foreground color. | ' +--------------+-----------------------------------------------------+ ' | BGColr% | The text back ground color. | ' +--------------+-----------------------------------------------------+ ' | FKey$ | Which keys to enable. To enabled | ' | | and , FKey$ = "150" ("0" is F10). | ' +--------------+-----------------------------------------------------+ ' | PW% | PW% = 1 - password mode enabled. | ' | | PW% = 0 - password mode NOT enabled. | ' +--------------+-----------------------------------------------------+ ' | Ins% | Ins% = 0 then INSERT OFF. Ins% = 1 then INSERT ON | ' +--------------+-----------------------------------------------------+ ' | TabUpDn$ | TabUpDn$ = "" nothing is initialized | ' | | TabUpDn$ = "T" initializes | ' | | TabUpDn$ = "U" initializes | ' | | TabUpDn$ = "D" initializes | ' | | TabUpDn$ = "TUD" initializes | ' | | | ' | | If one or more of these keys is initialized, then | ' | | the routine will exit showing the ExitCode% of the | ' | | pressed key. The programmer must make sure to | ' | | trap for the pressed key. Of course, if none | ' | | of these keys is to be employed, then place | ' | | TabUpDn$ = "" in the main module. | ' | | | ' | | : ExitCode% = 9 | ' | | : ExitCode% = 18432 | ' | | : ExitCode% = 20480 | ' | | | ' | | Example: | ' | | ------- | ' | | If ExitCode% = 18432 THEN ' | ' | | GOTO second.parameter | ' | | ELSEIF ExitCode% = 20480 THEN ' | ' | | GOTO fourth.parameter | ' | | 'Etc | ' | | | ' +--------------+-----------------------------------------------------+ ' | The ExitCode% is derived from the unique CVI Basic command. | ' | The ExitCode% for the keys gets changed to 1 to 10. | ' | To enable programmers to use the CVI code in their own programs, | ' | I have attached a short program, KeyCode.Bas (just below this | ' | section) | ' +------------------------------------+-------------------------------+ ' | ExitCode% = 1 is F1 key | I arbitrarily changed | ' | ExitCode% = 2 is F2 key | through to 1-10. | ' | ExitCode% = 3 is F3 key | Their CVI Codes are: | ' | ExitCode% = 4 is F4 key +-------------------------------+ ' | ExitCode% = 5 is F5 key | CVI: ExitCode: | ' | ExitCode% = 6 is F6 key | ---- --- -------- | ' | ExitCode% = 7 is F7 key | 15104 1 | ' | ExitCode% = 8 is F8 key | 15360 2 | ' | ExitCode% = 9 is F9 key | 15616 3 | ' | ExitCode% = 10 is F10 key | 15872 4 | ' | ExitCode% = 13 is ENTER key | 16128 5 | ' | ExitCode% = 27 is EXIT key | 17152 9 | ' | | 17408 10 | ' +------------------------------------+-------------------------------+ ' | Probably need to include at the top of the main module: DEFINT A-Z| ' +--------------------------------------------------------------------+ ' +--------------------------------------------------------------------+ ' | Use KeyCode.Bas below to find out what the CVI numbers will be | ' | for keys you wish to trap. | ' +--------------------------------------------------------------------+ ' | ' KeyCode.Bas - By Don Smith. FreeWare and Public Domain Program. | ' | ' Date: 09/01/2002. | ' | ' +-------------------------------------------------------------+ | ' | ' | Note: To reach the extended ASCII characters 127 to 255, | | ' | ' | press down on the key, and while pressed down, | | ' | ' | type in the number on your keypad, not the numbers | | ' | ' | above then keys. | | ' | ' +-------------------------------------------------------------+ | ' +--------------------------------------------------------------------+ ' | | ' | COLOR 14, 1: CLS | ' | Top1$ = "Press a key and the KeyCode% value will be displayed." | ' | Top2$ = "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~" | ' | Top3$ = "(Press To Quit" | ' | COLOR 15, 1 | ' | LOCATE 2, 15: PRINT Top1$ | ' | LOCATE 3, 15: PRINT Top2$ | ' | COLOR 11, 1 | ' | LOCATE 4, 30, 0: PRINT Top3$ | ' | PRINT : PRINT | ' | COLOR 14, 1 | ' | DO | ' | DO | ' | Hit$ = INKEY$ | ' | IF Hit$ = CHR$(27) THEN | ' | PRINT | ' | LOCATE , 10: COLOR 15, 1: PRINT STRING$(62, "-"); | ' | PRINT | ' | LOCATE , 34: COLOR 11, 1: PRINT "Program Ends"; | ' | PRINT : PRINT | ' | END | ' | END IF | ' | LOOP UNTIL Hit$ <> "" | ' | Hit% = CVI(Hit$ + CHR$(0)) | ' | Key$ = STR$(Hit%) | ' | IF Hit% < 256 THEN | ' | LOCATE , 32, 0 | ' | PRINT Hit$ + SPACE$(9) + "= " + Key$ | ' | ELSEIF Hit% > 255 THEN | ' | LOCATE , 21, 0 | ' | PRINT "Extended Key" + SPACE$(9) + "= " + Key$; "" | ' | END IF | ' | LOOP | ' | | ' +--------------------------------------------------------------------+ EdW$ = "": Ky$ = "" IF See% = 1 THEN LOCATE Row%, Col% COLOR FGColr%, BGColr% PRINT STRING$(LenStr%, " "); END IF TabUpDn$ = UCASE$(TabUpDn$) begin.edit.line: DO IF Ins% = 1 THEN 'Insert On COLOR FGColr%, BGColr%: LOCATE Row%, Col%, 1, 4, 7 ELSEIF Ins% = 0 THEN 'Insert Off COLOR FGColr%, BGColr%: LOCATE Row%, Col%, 1, 6, 7 END IF DO Ky$ = INKEY$ IF PW% = 1 THEN IF BlankIt% = 1 THEN BlankIt% = 0 END IF END IF LOOP UNTIL LEN(Ky$) > 0 SlamKey% = CVI(Ky$ + CHR$(0)) ' IF SlamKey% > 31 AND SlamKey% < 256 THEN 'CHR$(31) to CHR$255) IF TypeOfText$ = "" THEN 'CHR$(32) is IF PW% = 0 THEN GOSUB show.char ELSEIF PW% = 1 THEN GOSUB edit.password END IF ELSEIF TypeOfText$ <> "" THEN IF INSTR(TypeOfText$, Ky$) > 0 THEN IF PW% = 0 THEN GOSUB show.char ELSEIF PW% = 1 THEN GOSUB edit.password END IF END IF END IF ', ELSEIF SlamKey% = 9 OR SlamKey% = 18432 OR SlamKey% = 20480 THEN IF SlamKey% = 9 THEN TabUpDnKey$ = "T" ELSEIF SlamKey% = 18432 THEN TabUpDnKey$ = "U" ELSEIF SlamKey% = 20480 THEN TabUpDnKey$ = "D" END IF IF INSTR(TabUpDn$, TabUpDnKey$) > 0 THEN GOSUB get.string ExitCode% = SlamKey% EXIT SUB END IF ELSEIF SlamKey% = 27 THEN ' Key ExitCode% = 27 GOSUB get.string EXIT SUB ELSEIF SlamKey% = 19712 THEN ' Arrow Col% = Col% + 1 IF Col% > FCol% + LenStr% - 1 THEN Col% = FCol% ELSE LOCATE Row%, Col%, 1, 6, 7 END IF ELSEIF SlamKey% = 19200 THEN ' Col% = Col% - 1 IF Col% = FCol% - 1 OR Col% < FCol% THEN Col% = FCol% + LenStr% - 1 END IF ELSEIF SlamKey% = 13 THEN ' IF PW% = 0 THEN GOSUB get.string END IF ExitCode% = 13 EXIT SUB ELSEIF SlamKey% = 8 THEN ' Col% = Col% - 1 IF Col% = FCol% OR Col% < FCol% THEN Col% = FCol% END IF LOCATE Row%, Col% COLOR FGColr%, BGColr%: PRINT " "; IF PW% = 1 THEN EdW$ = LEFT$(EdW$, LEN(EdW$) - 1) END IF ELSEIF SlamKey% = 20992 THEN ' 'If 1 (on), turn off (0). If 0 (off), turn on (1). IF Ins% = 1 THEN Ins% = 0 'unREM if need to print "Insert Off/On" 'LOCATE 2, 66: Print "Insert Off "; ELSEIF Ins% = 0 THEN 'REM out "Insert Off/On" if not used. Ins% = 1 'LOCATE 2, 66: Print "Insert On "; END IF ELSEIF SlamKey% = 21248 THEN ' SaveScr$ = "" FOR DelK% = Col% + 1 TO FCol% + LenStr% SaveScr$ = SaveScr$ + CHR$(SCREEN(Row%, DelK%)) NEXT SaveScr$ = MID$(SaveScr$, 1, LEN(SaveScr$)) LOCATE Row%, Col% COLOR FGColr%, BGColr% PRINT SaveScr$; SaveScr$ = "" ELSEIF SlamKey% = 18176 THEN ' Col% = FCol% ELSEIF SlamKey% = 20224 THEN ' GOSUB get.string Col% = FCol% + LEN(EdW$) LOCATE Row%, Col%, 1, 6, 7 ELSEIF SlamKey% = 25 THEN ' = clears line of LOCATE Row%, FCol% 'all text. WipeOut$ = SPACE$(LenStr%) COLOR FGColr%, BGColr% PRINT WipeOut$; ELSEIF SlamKey% > 15103 OR SlamKey% < 17409 THEN ' to IdentKey$ = STR$(((SlamKey% - 15104) \ 256) + 1) IdentKey$ = LTRIM$(RTRIM$(IdentKey$)) IF IdentKey$ = "10" THEN IdentKey$ = "0" END IF IF INSTR(FKey$, IdentKey$) > 0 THEN IF IdentKey$ = "0" THEN ExitCode% = 10 GOSUB get.string EXIT SUB ELSE ExitCode% = VAL(IdentKey$) GOSUB get.string EXIT SUB END IF END IF END IF LOOP show.char: IF Ins% = 1 THEN ' FOR Horizontal% = Col% TO FCol% + LenStr% - 1 EditL$ = EditL$ + CHR$(SCREEN(Row%, Horizontal%)) NEXT IF Caps% > 0 THEN EditL$ = UCASE$(EditL$) Ky$ = UCASE$(Ky$) END IF COLOR FGColr%, BGColr% LOCATE Row%, Col%, 1 PRINT LEFT$(Ky$ + EditL$, FCol% + LenStr% - Col%); IF Col% = FCol% + LenStr% THEN Col% = FCol% - 1 END IF Col% = Col% + 1 EditL$ = "" ELSEIF Ins% = 0 THEN ' LOCATE Row%, Col% IF Caps% > 0 THEN COLOR FGColr%, BGColr%: PRINT UCASE$(Ky$); ELSEIF Caps% = 0 THEN COLOR FGColr%, BGColr%: PRINT Ky$; END IF Col% = Col% + 1 IF Col% = FCol% + LenStr% THEN Col% = FCol% RETURN END IF END IF RETURN get.string: EditLine$ = SPACE$(LenStr%) FOR Horizontal% = FCol% TO FCol% + LenStr% EditLine$ = EditLine$ + CHR$(SCREEN(Row%, Horizontal%)) NEXT EditLine$ = RTRIM$(LTRIM$(EditLine$)) EdW$ = EditLine$ RETURN edit.password: EdW$ = UCASE$(EdW$) + UCASE$(Ky$) COLOR FGColr%, BGColr% LOCATE Row%, Col% PRINT "ù"; 'CHR$(249) LOCATE Row%, Col% + 1, 1, 6, 7 IF Col% = FCol% + LenStr% THEN Col% = FCol% - 1 END IF Col% = Col% + 1 RETURN END SUB SUB endit (NDXfile$, DATfile$) ' +--------------------------------------------------------------------+ ' | | ' | SUB endit: is used to end program. It makes backup copies of | ' | menu and data files. | ' +--------------------------------------------------------------------+ DIM attr AS FileAttributesType CALL updateNDX CLOSE FOR CheckOutNDX% = 1 TO LEN(NDXfile$) DotNDX$ = MID$(NDXfile$, CheckOutNDX%, 1) IF DotNDX$ = "." THEN BackUpNDX$ = MID$(NDXfile$, 1, CheckOutNDX% - 1) BackUpNDX$ = BackUpNDX$ + ".MM" END IF NEXT IF DotNDX$ = "" THEN BackUpNDX$ = NDXfile$ + ".MM" END IF FOR CheckOutDAT% = 1 TO LEN(DATfile$) DotDAT$ = MID$(DATfile$, CheckOutDAT%, 1) IF DotDAT$ = "." THEN BackUpDAT$ = MID$(DATfile$, 1, CheckOutDAT% - 1) BackUpDAT$ = BackUpDAT$ + ".MD" END IF NEXT CALL GetFileAttributes(NDXfile$, attr) IF attr.result > 0 THEN GOTO end.it.now END IF CALL GetFileAttributes(DATfile$, attr) IF attr.result > 0 THEN GOTO end.it.now END IF SHELL "copy" + " " + NDXfile$ + " " + BackUpNDX$ + ">" + "TempM.Txt" SHELL "copy" + " " + DATfile$ + " " + BackUpDAT$ + ">" + "TempM.Txt" end.it.now: COLOR 7, 0: CLS : LOCATE 1, 1, 1, 6, 7: END END SUB FUNCTION FindDeleted% (GetNum%) ' +----------------------------------------------------------------------+ ' | This routine searches the index array for records starting with ASCII| ' | 20 and returns a non-zero (true) value to the dataentry sub. This | ' | indicates to dataentry that there is a deleted record and it's record| ' | number is finddeleted% and to store the new record in the record | ' | number finddeleted% | ' +----------------------------------------------------------------------+ GetNum% = 0 del$ = CHR$(20) FOR X% = 1 TO numberofrecords% indexname$ = index(X%).firstlast IF del$ = LEFT$(indexname$, 1) THEN GetNum% = index(X%).recordnumber index(X%).firstlast = Target$ EXIT FOR END IF NEXT X% FindDeleted% = GetNum% END FUNCTION SUB form (FGColr%, BGColr%) paint.face: COLOR 15, BGColr%: CLS COLOR FGColr%, BGColr% COLOR 15, BGColr% LOCATE 4, 3, 1, 6, 7: PRINT "Name - Last :"; LOCATE 4, 40, 1, 6, 7: PRINT "First :"; LOCATE 6, 3, 1, 6, 7: PRINT "Address:"; LOCATE 8, 3, 1, 6, 7: PRINT "City :"; LOCATE 8, 42, 1, 6, 7: PRINT "State :"; LOCATE 8, 57, 1, 6, 7: PRINT "Zip :"; LOCATE 10, 3, 1, 6, 7: PRINT "Phone :"; LOCATE 12, 3, 1, 6, 7: PRINT "Social Security # :"; LOCATE 12, 43, 1, 6, 7: PRINT "Date Of Birth :"; LOCATE 15, 3, 1, 6, 7: PRINT "Comments1 :"; LOCATE 16, 3, 1, 6, 7: PRINT "Comments2 :"; LOCATE 17, 3, 1, 6, 7: PRINT "Comments3 :"; LOCATE 18, 3, 1, 6, 7: PRINT "Comments4 :"; LOCATE 19, 3, 1, 6, 7: PRINT "Comments5 :"; LOCATE 24, 30, 1, 6, 7: PRINT "Press To Exit"; LOCATE 24, 37, 1, 6, 7: COLOR 11, BGColr%: PRINT "Esc"; CALL BigBox(1, 1, 25, 80, 9, BGColr%) CALL OneLine(3, 1, 9, BGColr%, 3, 78) CALL OneLine(21, 1, 9, BGColr%, 3, 78) CALL OneLine(23, 1, 9, BGColr%, 3, 78) COLOR 11, BGColr%: LOCATE 2, 13: PRINT "Please Fill In The CUSTOMER INFORMATION DATABASE Form:"; EXIT SUB END SUB REM $DYNAMIC SUB GetFileAttributes (fileName$, attr AS FileAttributesType) STATIC ' +---------------------------------------------------------------------+ ' | GetFileAttributes is used to determine if a file exists or not. | ' | See example, below: | ' +---------------------------------------------------------------------+ ' | | ' | To use SUB GetFileAttributes -> | ' | | ' | CALL GetFileAttributes (fileName$, attr) | ' | | ' | fileName$ will be one of these six: | ' | ----------------------------------- | ' | 1. CID.Doc | ' | 2. ShowOff.Exe | ' | 3. PrintIt.Exe | ' | 4. PrintDoc.Exe | ' | 5. NDXfile$ exists | ' | 6. DATfile$ exists | ' | | ' | IF attr.archive > 0 then | ' | 'file does not exist. Use a pop-up screen and | ' | 'back out. | ' | ELSE | ' | 'file does indeed exist. Continue with routine. | ' | END IF | ' | | ' +---------------------------------------------------------------------+ DIM regX AS RegTypeX regX.ax = &H4300 F$ = fileName$ + CHR$(0) regX.ds = VARSEG(F$) regX.dx = SADD(F$) InterruptX &H21, regX, regX IF regX.flags AND 1 THEN attr.result = regX.ax ELSE attr.result = 0 END IF attr.readOnly = regX.cx AND 1 attr.hidden = (regX.cx \ 2) AND 1 attr.systemFile = (regX.cx \ 4) AND 1 attr.archive = (regX.cx \ 32) AND 1 END SUB REM $STATIC SUB getname (FGColr%, BGColr%) ' +----------------------------------------------------------------------+ ' | This routine puts 15 sorted names from the index into a box and | ' | allows the user to choose one with a bounce-bar. User can see the | ' | next page or the previous page by using and

, correct name | ' | is highlighted and is pressed for record selection | ' +----------------------------------------------------------------------+ DIM attr AS FileAttributesType IF BGColr% = 0 THEN GetHiFG% = 0 GetHiBG% = 7 ELSEIF BGColr% = 1 THEN GetHiFG% = 15 GetHiBG% = 4 END IF top2: COLOR 15, BGColr% CALL BoxBoy("", 17, 20, 25, 58, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) COLOR 14, BGColr% LOCATE 20, 23: PRINT SPACE$(31); LOCATE 22, 23: PRINT SPACE$(31); COLOR 15, BGColr% LOCATE 18, 25: PRINT "Last Name? "; COLOR 14, BGColr% LOCATE 18, 36: PRINT SPACE$(22); COLOR 15, BGColr% LOCATE 20, 24: PRINT "Enter last name, first letter of"; LOCATE 21, 24: PRINT "last name, or press to"; COLOR 11, BGColr%: LOCATE 21, 45: PRINT "Enter"; : COLOR 15, BGColr% LOCATE 22, 24: PRINT "view all the names in database."; LOCATE 24, 24: PRINT "- Press To Quit Routine -"; LOCATE 24, 33: COLOR 12, BGColr%: PRINT "Esc"; CALL OneLine(19, 20, 11, BGColr%, 4, 38) CALL OneLine(23, 20, 11, BGColr%, 4, 38) LOCATE 20, 36: COLOR 14, BGColr% EdW$ = "" Row% = 18 Col% = 36 FCol% = 36 LenStr% = 20 See% = 0 TypeOfText$ = "" Caps% = 0 FGColr% = 14 BGColr% = BGColr% FKey$ = "" Ins% = 1 PW% = 0 TabUpDn$ = "" ExitCode% = 0 CALL EditLoco(EdW$, Row%, Col%, FCol%, LenStr%, See%, TypeOfText$, Caps%, FGColr%, BGColr%, FKey$, Ins%, PW%, TabUpDn$, ExitCode%) lastname$ = EdW$ IF ExitCode% = 27 THEN CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) END IF counter% = 1 Leng% = LEN(lastname$) start% = 1 searchstart: Row% = 5 second.counter% = 0 CALL GetFileAttributes(NDXfile$, attr) IF attr.result > 0 THEN COLOR 15, BGColr% LOCATE 20, 22: PRINT "Unable to follow your request! "; LOCATE 21, 22: PRINT "NO names were found in the "; LOCATE 22, 22: PRINT SPACE$(35); LOCATE 22, 22: PRINT UCASE$(NDXfile$); " menu file."; LOCATE 18, 33: COLOR 14, BGColr%: PRINT SPACE$(23); LOCATE 18, 36, 0: COLOR 30, BGColr%: PRINT "NO NAMES FOUND"; DO DO GoAhead$ = INKEY$ LOOP UNTIL LEN(GoAhead$) > 0 IF GoAhead$ = CHR$(27) THEN CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) END IF LOOP END IF REDIM Temp(1 TO UBOUND(index, 1)) AS indexrecord xstart: COLOR 15, BGColr%: CLS CALL BoxBoy("", 2, 19, 20, 60, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) CALL OneLine(4, 19, 11, BGColr%, 4, 41) COLOR 15, BGColr% LOCATE 3, 20: PRINT "Select a file <" + CHR$(25) + "> <" + CHR$(24) + "> and press "; COLOR 11, BGColr% LOCATE 3, 35: PRINT CHR$(25); : LOCATE 3, 39: PRINT CHR$(24); LOCATE 3, 53: PRINT "Enter"; LOCATE 24, 7 COLOR 15, BGColr% PRINT "MOVE: <" + CHR$(25) + "> <" + CHR$(24) + "> NEXT PAGE: <Í" + CHR$(16) + "> BACK PAGE: <" + CHR$(17) + "Í> QUIT: "; LOCATE 24, 71: COLOR 12, BGColr%: PRINT "Esc"; COLOR 11, BGColr% LOCATE 24, 7: PRINT "MOVE"; : LOCATE 24, 25: PRINT "NEXT PAGE"; LOCATE 24, 45: PRINT "BACK PAGE"; : LOCATE 24, 64: PRINT "QUIT"; COLOR 15, BGColr% FOR array% = start% TO UBOUND(index, 1) second.counter% = second.counter% + 1 IF UCASE$(MID$(index(array%).firstlast, 1, Leng%)) = UCASE$(lastname$) THEN IF UCASE$(LEFT$(index(array%).firstlast, 1)) = CHR$(20) THEN GOTO Again END IF LOCATE Row%, 20 PRINT UCASE$(index(array%).firstlast) Temp(counter%).firstlast = index(array%).firstlast Temp(counter%).recordnumber = index(array%).recordnumber Temp(counter%).Pointer = array% Row% = Row% + 1 counter% = counter% + 1 IF counter% > 15 THEN GOTO bouncebar END IF END IF Again: NEXT array% bouncebar: ' temprow% = 5 endcounter% = counter% - 1 counter% = 1 GOSUB HighLight IF Temp(counter%).recordnumber = 0 THEN COLOR 15, BGColr%: CLS CALL BoxBoy("", 7, 20, 16, 58, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) CALL OneLine(9, 20, 11, BGColr%, 4, 38) CALL OneLine(12, 20, 11, BGColr%, 4, 38) COLOR 12, BGColr% LOCATE 8, 38: PRINT "Oops!"; COLOR 15, BGColr% LOCATE 10, 24: PRINT "Sorry! Unable to find that name."; LOCATE 11, 24: PRINT "Please try again. "; LOCATE 13, 24: PRINT "Press to try again, or"; LOCATE 14, 24: PRINT "press to return to the"; LOCATE 15, 24: PRINT "Main Menu."; COLOR 11, BGColr% LOCATE 13, 31: PRINT "Enter"; LOCATE 14, 31: PRINT "Esc"; COLOR 15, BGColr% DO DO Esc$ = INKEY$ LOOP UNTIL LEN(Esc$) > 0 IF Esc$ = CHR$(27) THEN CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) ELSEIF Esc$ = CHR$(13) THEN GOTO top2 END IF LOOP ELSE PRINT UCASE$(Temp(counter%).firstlast); END IF DO DO keystroke$ = INKEY$ LOOP WHILE keystroke$ = "" tempkey% = ASC(RIGHT$(keystroke$, 1)) tempscankey% = ASC(LEFT$(keystroke$, 1)) IF tempscankey% = 0 THEN SELECT CASE tempkey% CASE 72 ' IF temprow% = 5 THEN GOSUB LowLight PRINT UCASE$(Temp(counter%).firstlast); temprow% = Row% - 1 counter% = endcounter% GOSUB HighLight PRINT UCASE$(Temp(counter%).firstlast); ELSE temprow% = CSRLIN GOSUB LowLight PRINT UCASE$(Temp(counter%).firstlast); counter% = counter% - 1 temprow% = temprow% - 1 GOSUB HighLight PRINT UCASE$(Temp(counter%).firstlast); END IF CASE 80 ' temprow% = CSRLIN IF temprow% = Row% - 1 THEN counter% = 1 temprow% = Row% - 1 GOSUB LowLight PRINT UCASE$(Temp(endcounter%).firstlast); temprow% = 5 counter% = 1 GOSUB HighLight PRINT UCASE$(Temp(counter%).firstlast); ELSE GOSUB LowLight PRINT UCASE$(Temp(counter%).firstlast); counter% = counter% + 1 temprow% = temprow% + 1 GOSUB HighLight PRINT UCASE$(Temp(counter%).firstlast); END IF CASE 75 ' counter% = 1 Row% = 5 start% = start% - 15 IF start% < 1 THEN start% = 1 second.counter% = 0 counter% = 1 END IF cksound% = cksound% - 1 IF cksound% = -1 THEN cksound% = 0 SOUND 200, 2 END IF GOTO xstart CASE 77 ' IF array% > UBOUND(index, 1) THEN SOUND 200, 2 GOTO bouncebar END IF cksound% = cksound% + 1 counter% = 1 tempcounter% = 5 start% = array% + 1 Row% = 5 GOTO xstart END SELECT ELSEIF tempscankey% <> 0 THEN SELECT CASE UCASE$(keystroke$) CASE IS = CHR$(27) CALL MenuCall(FGColr%, BGColr%, NDXfile$, DATfile$, 1) END SELECT END IF LOOP UNTIL keystroke$ = CHR$(13) VIEW PRINT GET #1, Temp(counter%).recordnumber, names EXIT SUB HighLight: COLOR GetHiFG%, GetHiBG% LOCATE temprow%, 20, 0 PRINT SPACE$(30); LOCATE temprow%, 20, 0 RETURN LowLight: COLOR FGColr%, BGColr% LOCATE temprow%, 20, 0 PRINT SPACE$(30); LOCATE temprow%, 20, 0 RETURN END SUB SUB MenuCall (FGColr%, BGColr%, NDXfile$, DATfile$, ExistNum%) STATIC '+--------------------------------------------------------------------+ '| SUB MenuCall | '+--------------------------------------------------------------------+ '| FGColr% Foreground color of menu. | '| BGColr% Background color of menu. | '| NDXfile$ Menu file containing customer names. | '| DATfile$ Data file with customer data. | '| ExistNum% Number on the opening menu. | '+--------------------------------------------------------------------+ IF ExistNum% = 1 THEN '------ +------------------------------------------+ GOTO thetop ' | Use ExistNum% to CALL MenuCall from | END IF ' | another SUB and reenter the SDMenu with | ' | the same row as previously set. Use: | Row% = 8: TopRow% = 8 ' | CALL MenuCall(FBColr%, BGColr%, NDXfile$,| NDXfile$ = UCASE$(NDXfile$) ' | DATfile$, 1) | DATfile$ = UCASE$(DATfile$) ' +------------------------------------------+ thetop: M$ = "" ErrExist% = 0 DIM attr AS FileAttributesType REDIM M$(8) M$(1) = " 1. Find A Record " M$(2) = " 2. Add A Record " M$(3) = " 3. Edit A Record " M$(4) = " 4. Delete A Record " M$(5) = " 5. Print Name(s) " M$(6) = " 6. PreView " M$(7) = " 7. Documentation " M$(8) = " 8. Quit " BGColr% = 1 COLOR 11, BGColr%: CLS LOCATE 3, 24: COLOR 15, BGColr% Title$ = "CUSTOMER INFORMATION DATABASE" TLen% = LEN(Title$) CALL BoxBoy("", 2, 24, 4, 55, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) CALL BoxBoy("", 7, 27, 16, 51, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) COLOR 15, BGColr% LOCATE 3, 26 PRINT Title$; CALL BoxBoy("", 20, 27, 22, 51, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) LOCATE 21, 30: COLOR 15, BGColr% PRINT "Press For Help"; LOCATE 21, 37: COLOR 11, BGColr%: PRINT "F1"; IF BGColr% = 0 THEN FGColr% = 15: BGColr% = 0 HiLiteFG% = 0: HiLiteBG% = 7 ELSEIF BGColr% = 1 THEN FGColr% = 15: BGColr% = 1 HiLiteFG% = 15: HiLiteBG% = 4 END IF TypeOfKeys$ = "KkRrBbMmCcSs12345678" FKeys$ = "150" ExitCode% = 0 CALL SDMenu(M$(), Row%, TopRow%, 29, Num%, 8, FGColr%, BGColr%, HiLiteFG%, HiLiteBG%, 0, TypeOfKeys$, FKeys$, selection%, ExitCode%) TempSelection% = selection% IF ExitCode% = 27 THEN ' CALL endit(NDXfile$, DATfile$) 'To set up and , use FKeys$ = "015" ELSEIF ExitCode% = 101 THEN ' GOTO f1.pressed ELSEIF ExitCode% = 105 THEN ' selection% = 9 GOTO f1.pressed ELSEIF ExitCode% = 110 THEN ' GOSUB smith.id GOTO thetop ' To set up <1-8> and and , ' use TypeOfKeys$ = "KkRrBbMmCcSs123456787". Selection numbers ' 1-8 are reported as Selection% = 1 to 8. The upper and lower case ' letters are reported as ExitCode% numbers. To discover what these ' numbers are, go to SUB SDMenu and look up KeyCode.Bas. ELSEIF ExitCode% = 107 OR ExitCode% = 75 THEN ' or selection% = 11 GOTO f1.pressed ELSEIF ExitCode% = 114 OR ExitCode% = 82 THEN ' or GOTO restore.files GOTO thetop ELSEIF ExitCode% = 98 OR ExitCode% = 66 THEN ' or GOTO thetop ELSEIF ExitCode% = 109 OR ExitCode% = 77 THEN ' or CALL CheckStatus(4, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(5, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN GOTO thetop END IF GOTO mirror.files ELSEIF ExitCode% = 99 OR ExitCode% = 67 THEN ' or GOTO copy.one ELSEIF ExitCode% = 115 OR ExitCode% = 83 THEN ' or start.ok% = 1 GOTO search.dob END IF IF selection% = 1 THEN '< 1. Find A Record > GOTO Find ELSEIF selection% = 2 THEN '< 2. Add A Record > GOTO datain ELSEIF selection% = 3 THEN '< 3. Edit A Record > GOTO Edit ELSEIF selection% = 4 THEN '< 4. Delete A Record> GOTO Delete ELSEIF selection% = 5 THEN '< 5. Print Name(s) > GOTO printsetup ELSEIF selection% = 6 THEN '< 6. Preview > GOTO printsetup ELSEIF selection% = 7 THEN '< 7. Documentation > GOTO Info ELSEIF selection% = 8 THEN '< 8. Quit > CALL endit(NDXfile$, DATfile$) ELSEIF selection% = 9 THEN selection% = Num% GOTO thetop END IF GOTO thetop Find: CALL getname(FGColr%, BGColr%) CALL displaydata(FGColr%, BGColr%) GOTO thetop datain: CALL dataentry(FGColr%, BGColr%) GOTO thetop Edit: CALL getname(FGColr%, BGColr%) CALL Edit(FGColr%, BGColr%) GOTO thetop Delete: CALL getname(FGColr%, BGColr%) Delete FGColr%, BGColr% GOTO thetop Info: CALL CheckStatus(2, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(1, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN GOTO thetop END IF IF BGColr% = 0 THEN SHELL "showoff.exe" + " " + "cid.txt" + " /m " ELSEIF BGColr% = 1 THEN SHELL "showoff.exe" + " " + "cid.txt" END IF GOTO thetop printsetup: M$ = "": P$ = "": PrnSelection% = 0 IF selection% = 6 THEN CALL CheckStatus(2, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(4, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(5, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN selection% = TempSelection% GOTO thetop END IF IF BGColr% = 0 THEN SixFG% = 12: SixBG% = 0 ELSEIF BGColr% = 1 THEN SixFG% = 15: SixBG% = 4 END IF CALL PrintName(4, FirstLetter$, FGColr%, BGColr%) GOTO thetop END IF IF selection% = 5 THEN CALL CheckStatus(3, NDXfile$, DATfile$, ErrExist%) IF ErrExist% = 3 THEN NoGoThree% = 1 END IF CALL CheckStatus(6, NDXfile$, DATfile$, ErrExist%) IF ErrExist% = 6 THEN NoGoSix% = 1 END IF IF NoGoThree% = 1 AND NoGoSix% = 1 THEN CALL BoxBoy("", 17, 16, 23, 64, 1, 1, 1, 1, 11, 1, 2, 0, 0, 0) CALL OneLine(19, 16, 11, 1, 4, 48) LOCATE 18, 33: COLOR 12, 1: PRINT "<<< ERROR >>>"; LOCATE 20, 19: COLOR 15, 1 PRINT "Unable To Find: PrintIt.Exe Or PrintDoc.Exe"; CALL OneLine(21, 16, 11, 1, 4, 48): COLOR 15, 1 LOCATE 22, 29: PRINT "Press To Continue"; LOCATE 22, 36, 0, 0, 0: COLOR 11, 1: PRINT "ESC"; SOUND 150, 2 CALL CviCall(HitKey%) IF HitKey% = 27 THEN GOTO thetop ELSE GOTO printsetup END IF END IF END IF COLOR 15, BGColr% IF BGColr% = 0 THEN PrnFG% = 0: PrnBG% = 7 ELSEIF BGColr% = 1 THEN PrnFG% = 15: PrnBG% = 4 END IF CALL BoxBoy("", 8, 23, 15, 53, 0, 0, 0, 0, PrnFG%, PrnBG%, 2, 0, 0, 1) COLOR PrnFG%, PrnBG% IF BGColr% = 1 THEN COLOR 11, 4 END IF LOCATE 9, 28: PRINT "PRINT ROUTINE:"; CALL OneLine(10, 24, PrnFG%, PrnBG%, 4, 30) REDIM P$(4) P$(1) = "1. Print A Name " P$(2) = "2. Print A Block Of Names" P$(3) = "3. Print All Names " P$(4) = "4. Exit Print Routine " PRow% = 11: PTopRow% = 11 SD% = 0 TypeOfKeys$ = "1234": FKeys$ = "" CALL SDMenu(P$(), PRow%, PTopRow%, 27, PrnNum%, 4, PrnFG%, PrnBG%, 15, 0, SD%, TypeOfKeys$, FKeys$, PrnSelection%, ExitCode%) IF PrnSelection% < 0 OR PrnSelection% > 4 THEN PrnSelection% = Num% GOTO printsetup END IF IF ExitCode% = 27 THEN GOTO thetop END IF IF ErrExist% > 0 THEN GOTO thetop END IF IF PrnSelection% = 1 THEN GOTO printone ELSEIF PrnSelection% = 2 THEN GOTO printblock ELSEIF PrnSelection% = 3 THEN GOTO printall ELSEIF PrnSelection% = 4 THEN GOTO thetop END IF printone: COLOR 15, BGColr% FOR clearapath% = 17 TO 25 LOCATE clearapath%, 1 PRINT SPACE$(80); NEXT CALL getname(FGColr%, BGColr%) CALL PrintName(1, firstname$, FGColr%, BGColr%) GOTO thetop printblock: COLOR 15, BGColr% CALL BoxBoy("", 19, 22, 23, 57, 0, 0, 0, 0, 11, BGColr%, 2, 0, 0, 0) COLOR 14, BGColr% LOCATE 20, 23: PRINT SPACE$(31); LOCATE 22, 23: PRINT SPACE$(31); COLOR 15, BGColr% LOCATE 20, 25: PRINT "First Letter Of Last Names? "; LOCATE 22, 25: PRINT "Press To Quit Routine"; LOCATE 22, 32: COLOR 12, BGColr%: PRINT "Esc"; CALL OneLine(21, 22, 11, BGColr%, 4, 35) LOCATE 20, 36: COLOR 14, BGColr% EdW$ = "" Row% = 20 Col% = 53 FCol% = 53 LenStr% = 1 See% = 0 TypeOfText$ = "" Caps% = 1 FGColr% = 14 BGColr% = BGColr% FKey$ = "" Ins% = 1 PW% = 0 TabUpDn$ = "" ExitCode% = EditCode% CALL EditLoco(EdW$, Row%, Col%, FCol%, LenStr%, See%, TypeOfText$, Caps%, FGColr%, BGColr%, FKey$, Ins%, PW%, TabUpDn$, ExitCode%) IF EdW$ = "" THEN Row% = 12 TopRow% = 8 ExistNum% = 5 GOTO thetop END IF FirstLetter$ = EdW$ IF ExitCode% = 27 THEN GOTO thetop ELSE CALL CheckStatus(4, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(5, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN GOTO thetop END IF ZeeCount% = 0 FOR WhatJuName% = 1 TO UBOUND(index, 1) GET #1, index(WhatJuName%).recordnumber, names IF UCASE$(LEFT$(names.last, 1)) = UCASE$(EdW$) THEN ZeeCount% = ZeeCount% + 1 LOCATE 5 + ZeeCount%, 19 PRINT UCASE$(names.last) + ", " + UCASE$(names.first); COLOR FGColr%, BGColr% IF ZeeCount% = 17 THEN EXIT FOR END IF END IF IF ZeeCount% = 1 THEN GOSUB paint.scrn COLOR FGColr%, BGColr% LOCATE 23, 18, 0: PRINT STRING$(44, "Í"); END IF NEXT IF ZeeCount% = 0 THEN CALL BoxBoy("", 19, 21, 23, 56, 0, 0, 0, 0, 12, BGColr%, 2, 0, 0, 1) COLOR 15, BGColr% LOCATE 20, 27: PRINT "Sorry! Unable To Find Any"; LOCATE 20, 32: COLOR 14, BGColr%: PRINT "!"; COLOR 15, BGColr% LOCATE 21, 27: PRINT "Names Beginning With "; CHR$(34); FirstLetter$; CHR$(34); "."; LOCATE 21, 49: COLOR 14, BGColr%: PRINT FirstLetter$; COLOR 15, BGColr% LOCATE 22, 27: PRINT "( )"; COLOR 11, BGColr% LOCATE 22, 28, 0: PRINT "Press Any Key To Continue" DO: LOOP WHILE INKEY$ = "" GOTO thetop END IF CALL CviCall(HitKey%) IF HitKey% = 121 OR HitKey% = 89 THEN ' or CALL PrintName(3, FirstLetter$, FGColr%, BGColr%) ' or or ELSEIF HitKey = 27 OR HitKey% = 110 OR HitKey% = 78 THEN GOTO thetop END IF END IF GOTO thetop printall: CALL CheckStatus(4, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(5, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN GOTO thetop END IF CALL PrintName(2, FirstLetter$, FGColr%, BGColr%) GOTO thetop paint.scrn: CALL BigBox(1, 17, 23, 62, FGColr%, BGColr%) FOR ClearPrnBox% = 1 TO 20 LOCATE 3 + ClearPrnBox%, 18 PRINT SPACE$(44); NEXT LOCATE 6, 19 PRINT UCASE$(RTRIM$(LTRIM$(names.last))) + ", " + UCASE$(RTRIM$(LTRIM$(names.first))); CALL OneLine(3, 17, FGColr%, BGColr%, 4, 44) CALL OneLine(5, 17, FGColr%, BGColr%, 4, 44) COLOR 14, BGColr% LOCATE 2, 22: PRINT " - BLOCK PRINTING ROUTINE - " COLOR FGColr%, BGColr% LOCATE 4, 23: PRINT "Print These Kinds Of Names (Y/N)?"; COLOR 11, BGColr% LOCATE 4, 51: PRINT "Y"; LOCATE 4, 53: PRINT "N"; RETURN f1.pressed: REDIM F1PressLines$(25): REDIM F1PressColr%(25, 80) CALL SaveRestScrn(F1PressLines$(), F1PressColr%(), 1, 1, 25, 80, 1) f1.pressed.again: IF BGColr% = 0 THEN BGColrHelp$ = "M" IF BGColr% = 1 THEN BGColrHelp$ = "R" IF selection% > 0 AND selection% < 8 THEN SHELL "cidhelp.exe" + " " + "0" + RTRIM$(LTRIM$(STR$(selection%))) + BGColrHelp$ + " /" + NDXfile$ + " /" + DATfile$ ELSEIF selection% = 9 THEN ' SHELL "cidhelp.exe" + " " + "09" + BGColrHelp$ + " /" + NDXfile$ + " /" + DATfile$ ELSEIF selection% = 11 THEN ' SHELL "cidhelp.exe" + " " + "11" + BGColrHelp$ + " /" + NDXfile$ + " /" + DATfile$ GOTO selection.eleven.kk ELSEIF selection% = 8 THEN '8 on main menu - Quit IF BGColr% = 1 THEN FGColrSel8% = 15: BGColrSel8% = 4 ELSEIF BGColr% = 0 THEN FGColrSel8% = 12: BGColrSel8% = 0 END IF CALL BoxBoy("", 20, 26, 22, 50, 1, 1, 1, 1, FGColrSel8%, BGColrSel8%, 1, 0, 0, 1) LOCATE 21, 29: COLOR 15, BGColrSel8%: PRINT "You Wish To Exit? (Y/N)"; COLOR 11, BGColrSel8% LOCATE 21, 48: PRINT "Y"; LOCATE 21, 50: PRINT "N"; LOCATE 15, 29: COLOR FGColr%, BGColr%: PRINT " 8. Quit " DO CALL CviCall(HitKey%) ' or or IF HitKey% = 121 OR HitKey% = 89 OR HitKey% = 27 THEN COLOR 7, 0: CLS : END ELSEIF HitKey% = 110 OR HitKey% = 78 THEN ' or PressDif% = selection% GOTO thetop END IF LOOP END IF DO CALL CviCall(HitKey%) '<1> or IF HitKey% = 49 OR HitKey% = 13 THEN 'check exist: CALL CheckStatus(2, NDXfile$, DATfile$, ErrExist%) '1) showoff.exe CALL CheckStatus(1, NDXfilel$, DATfile$, ErrExist%) '2) cid.doc IF ErrExist% > 0 THEN selection% = TempSelection% GOTO thetop END IF IF BGColr% = 0 THEN SHELL "showoff" + " " + "cid.txt" + " /m" ELSEIF BGColr% = 1 THEN SHELL "showoff.exe" + " " + "cid.txt" END IF selection% = TempSelection% GOTO thetop '<2> or or ELSEIF HitKey% = 50 OR HitKey% = 75 OR HitKey% = 107 THEN selection% = 11 GOTO f1.pressed.again '<3> or ELSEIF HitKey% = 51 OR HitKey% = 27 THEN selection% = TempSelection% GOTO thetop END IF LOOP selection.eleven.kk: DO DO PressKey$ = INKEY$ LOOP UNTIL PressKey$ <> "" HelpKey% = CVI(PressKey$ + CHR$(0)) IF HelpKey% = 99 OR HelpKey% = 67 THEN ' or selection% = TempSelection% CALL SaveRestScrn(F1PressLines$(), F1PressColr%(), 1, 1, 25, 80, 2) ERASE F1PressLines$: ERASE F1PressColr% GOTO copy.one ELSEIF HelpKey% = 75 OR HelpKey% = 107 THEN ' or IF BGColr% = 1 THEN OopsFG% = 15: OopsBG% = 1 ELSEIF BGColr% = 0 THEN OopsFG% = 0: OopsBG% = 7 END IF CALL BoxBoy("", 6, 19, 13, 58, 1, 1, 1, 1, OopsFG%, OopsBG%, 1, 0, 0, 1) Line$ = "Ã" + STRING$(39, CHR$(196)) + "´" COLOR OopsFG%, OopsBG% LOCATE 7, 36: PRINT "­ Oops !"; LOCATE 8, 20: PRINT Line$; LOCATE 9, 25: PRINT "You are already looking at the"; LOCATE 10, 25: PRINT "Special Keys window right now!"; LOCATE 11, 20: PRINT Line$; LOCATE 12, 28: PRINT "(Press To Continue)"; IF BGColr% = 1 THEN LOCATE 7, 36: COLOR 14, 1: PRINT "­ Oops !"; LOCATE 12, 36: COLOR 11, 1: PRINT "Esc"; END IF CALL Noise DO: LOOP UNTIL INKEY$ = CHR$(27) help = 11 selection% = 11 GOTO f1.pressed.again ELSEIF HelpKey% = 109 OR HelpKey% = 77 THEN ' or CALL SaveRestScrn(F1PressLines$(), F1PressColr%(), 1, 1, 25, 80, 2) ERASE F1PressLines$: ERASE F1PressColr% selection% = TempSelection% GOTO mirror.files ELSEIF HelpKey% = 114 OR HelpKey% = 82 THEN ' or CALL SaveRestScrn(F1PressLines$(), F1PressColr%(), 1, 1, 25, 80, 2) ERASE F1PressLines$: ERASE F1PressColr% selection% = TempSelection% GOTO restore.files ELSEIF HelpKey% = 98 OR HelpKey% = 66 THEN ' or selection% = TempSelection% GOSUB blank.it GOTO thetop ELSEIF HelpKey% = 16128 THEN ' COLOR FGColr%, BGColr% FOR ClearBottom% = 1 TO 3 LOCATE ClearBottom% + 16, 1 PRINT SPACE$(80); NEXT selection% = 9 GOTO f1.pressed.again ELSEIF HelpKey% = 115 OR HelpKey% = 83 THEN ' or start.ok% = 1 GOTO search.dob GOTO thetop ELSEIF HelpKey% = 17408 THEN ' selection% = TempSelection% GOTO smith.id GOTO thetop ELSEIF HelpKey% = 13 OR HelpKey% = 49 THEN ' or <1> CALL CheckStatus(1, NDXfile$, DATfile$, ErrExist%) CALL CheckStatus(2, NDXfile$, DATfile$, ErrExist%) IF ErrExist% > 0 THEN GOTO thetop END IF IF BGColr% = 0 THEN SHELL "showoff.exe" + " " + "cid.txt" + " /m" ELSEIF BGColr% = 1 THEN SHELL "showoff.exe" + " " + "cid.txt" END IF selection% = TempSelection% GOTO thetop ELSEIF HelpKey% = 27 OR HelpKey% = 50 THEN ' or <2> selection% = TempSelection% GOTO thetop END IF LOOP blank.it: Message1$ = "SCREEN BLANKED TO PROTECT MONITOR. PRESS TO EXIT. " Message2$ = "* CUSTOMER INFORMATION DATABASE *" BRow% = 3: BCol% = 12 Halt = 0 DO COLOR 0, 0, 0: CLS LOCATE Row%, Col% + 1, 0, 0, 0 CALL BoxBoy("", BRow% - 2, BCol% - 2, BRow% + 1, BCol% + 59, 1, 1, 1, 1, 7, 0, 2, 0, 0, 0) LOCATE BRow%, 13, 0 PRINT Message1$; LOCATE BRow% - 1, 23, 0: COLOR 14, 0: PRINT Message2$; SLEEP 15 '(15 seconds) BRow% = BRow% + 3 IF BRow% > 23 THEN BRow% = 3 END IF Halt = 0 LOOP UNTIL INKEY$ = CHR$(27) RETURN copy.one: EdW$ = "" IF BGColr% = 1 THEN SaveFG% = 15: SaveBG% = 4 ELSEIF BGColr% = 0 THEN SaveFG% = 0: SaveBG% = 3 END IF CALL BoxBoy("", 4, 8, 16, 69, 1, 1, 1, 1, SaveFG%, SaveBG%, 1, 0, 0, 1) SMessage$ = "Give Drive and Path to place the two backup files." TMessage$ = "PLEASE end with a back slash (\). The two files which" UMessage$ = "will be copied are:" LOCATE 5, 12: PRINT SMessage$; LOCATE 6, 12: PRINT TMessage$; LOCATE 7, 12: PRINT UMessage$; LOCATE 7, 32: PRINT "(1) (2)"; IF BGColr% = 1 THEN COLOR 11, 4 LOCATE 7, 36: PRINT UCASE$(NDXfile$); LOCATE 7, 53: PRINT UCASE$(DATfile$); COLOR SaveFG%, SaveBG% LOCATE 8, 9: PRINT CHR$(195) + STRING$(61, CHR$(196)) + CHR$(180); LOCATE 9, 12: PRINT "Examples: (1) To a floppy -" + CHR$(16) + " A:\"; LOCATE 10, 23: PRINT "(2) To hard disk -" + CHR$(16) + " C:\MYFILES\"; IF BGColr% = 1 THEN COLOR 11, 4 LOCATE 9, 24: PRINT "1"; : LOCATE 10, 24: PRINT "2"; END IF CALL BoxBoy("", 11, 13, 13, 64, 1, 1, 1, 1, SaveFG%, SaveBG%, 1, 0, 0, 0) LOCATE 14, 12 PRINT "Press after typing in the Drive and Path or"; LOCATE 15, 12 PRINT "press at any time to return to the Main Menu."; IF BGColr% = 1 THEN COLOR 11, 4 LOCATE 14, 19: PRINT "Enter"; LOCATE 15, 19: PRINT "Esc"; END IF copy.one.path: EdW$ = "" Row% = 12 Col% = 15 FCol% = 15 LenStr% = 48 See% = 1 TypeOfText$ = "" Caps% = 1 FGColr% = SaveFG% BGColr% = SaveBG% FKey$ = "" Ins% = 1 PW% = 0 TabUpDn$ = "" ExitCode% = ExitCode% CALL EditLoco(EdW$, Row%, Col%, FCol%, LenStr%, See%, TypeOfText$, Caps%, FGColr%, BGColr%, FKey$, Ins%, PW%, TabUpDn$, ExitCode%) IF BGColr% = 0 OR BGColr% = 4 THEN EmptyFG% = 15: EmptyBG% = 0 ELSEIF BGColr% = 1 THEN EmptyFG% = 15: EmptyBG% = 1 END IF IF ExitCode% = 13 THEN SlashFound% = 0 ColonFound% = 0 FOR FindSlash% = 1 TO LEN(EdW$) Slash$ = MID$(EdW$, FindSlash%, 1) IF Slash$ = "\" THEN 'Two examples are-> A:\ or C:\BASIC\CID\ SlashFound% = SlashFound% + 1 END IF NEXT IF SlashFound% > 1 THEN CkItOut% = LEN(EdW$) IF RIGHT$(EdW$, 1) = "\" THEN EdW$ = LEFT$(EdW$, LEN(EdW$) - 1) END IF ELSEIF SlashFound% = 1 THEN IF LEN(EdW$) > 3 THEN SlashFound% = 0 END IF END IF FOR Find% = 1 TO LEN(EdW$) Colon$ = MID$(EdW$, Find%, 1) IF Colon$ = ":" THEN ColonFound% = 1 EXIT FOR END IF NEXT IF ColonFound% = 0 OR SlashFound% = 0 OR EdW$ = "" THEN CALL BoxBoy("", 7, 12, 14, 65, 1, 1, 1, 1, EmptyFG%, EmptyBG%, 1, 0, 0, 1) LOCATE 8, 34: COLOR 12, EmptyBG%: PRINT "<<< Error >>>"; CALL OneLine(9, 13, EmptyFG%, EmptyBG%, 1, 53) LOCATE 10, 15: PRINT "Either no drive/path was given, or the drive/path"; LOCATE 11, 15 PRINT "was entered incorrectly. Check that you have ended"; 'ress To Return."; LOCATE 12, 15 PRINT "with a back slash (\). Press to try again,"; LOCATE 13, 15 PRINT "or press to return to the main menu."; COLOR 11, EmptyBG% LOCATE 12, 34: PRINT "\"; : LOCATE 12, 46: PRINT "Enter"; LOCATE 13, 25, 0: PRINT "Esc"; CALL Noise DO CALL CviCall(HitKey%) IF HitKey% = 27 THEN GOTO thetop ELSEIF HitKey% = 13 THEN GOTO copy.one END IF LOOP END IF GOTO continue.copy.one ELSEIF ExitCode% = 27 THEN LOCATE 1, 1, 0, 0, 0 EdW$ = "" GOTO thetop END IF continue.copy.one: CALL BoxBoy("", 5, 12, 14, 65, 1, 1, 1, 1, 15, EmptyBG%, 1, 0, 0, 1) LOCATE 6, 16, 0, 0, 0 PRINT "Backing up: (1) " + NDXfile$ + " and (2) " + DATfile$; Line$ = CHR$(195) + STRING$(53, 196) + CHR$(180) LOCATE 7, 13: PRINT Line$; LOCATE 10, 27, 0 COLOR 12, EmptyBG% SHELL "copy" + " " + NDXfile$ + " " + EdW$ + " > " + "dummy1.txt" FOR CkDrive% = 1 TO 18 CkDrive$ = CkDrive$ + CHR$(SCREEN(12, CkDrive%)) NEXT IF CkDrive$ = "Abort, Retry, Fail" THEN COLOR 12, BGColr% CALL BoxBoy("***Error***", 9, 16, 11, 61, 10, 19, 12, 0, 12, 0, 1, 0, 0, 1) LOCATE 10, 32: COLOR 15, 0: PRINT "Unable to copy. Press ."; LOCATE 10, 56: COLOR 12, 0: PRINT "Esc"; DO: LOOP UNTIL INKEY$ = CHR$(27) GOTO thetop END IF LOCATE 11, 27: SHELL "copy" + " " + DATfile$ + " " + EdW$ + " > " + "dummy2.txt" OPEN "dummy1.txt" FOR INPUT AS #55 LINE INPUT #55, Dummy1.Txt$ CLOSE #55 KILL "Dummy1.Txt" OPEN "Dummy2.Txt" FOR INPUT AS #57 LINE INPUT #57, Dummy2.Txt$ CLOSE #57 KILL "Dummy2.Txt" COLOR 15, BGColr% LOCATE 9, 23: PRINT Dummy1.Txt$; LOCATE 10, 23: PRINT Dummy2.Txt$; LOCATE 12, 13: PRINT Line$; LOCATE 13, 27: PRINT "Press To Continue."; LOCATE 13, 34, 0: COLOR 11, BGColr%: PRINT "Esc"; DO: LOOP UNTIL INKEY$ = CHR$(27) GOTO thetop RETURN restore.files: IF BGColr% = 0 THEN RestFG% = 0: RestBG% = 7 ELSEIF BGColr% = 1 THEN RestFG% = 15: R