home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / database / creator.zip / CREATOR.LBR / c451.lib next >
Text File  |  2011-02-01  |  8KB  |  118 lines
  1. 21 DEF FNPH$(X%)=CHR$(X%+128):DEF FNUH(X$)=ASC(X$)-128
  2. 100 KEY OFF:PRINT
  3. 110 PRINT"Enter data............................................................Depress E":PRINT
  4. 120 PRINT"Look up a record......................................................Depress L":PRINT
  5. 130 PRINT"Scan all records......................................................Depress S":PRINT
  6. 140 PRINT"Update a record.......................................................Depress U":PRINT
  7. 150 PRINT"Delete a record.......................................................Depress D":PRINT
  8. 160 PRINT"Exit this program.....................................................Depress X":PRINT
  9. 170 PRINT"Initialize the file...................................................Depress I":PRINT
  10. 180 GET 2,1:PRINT:PRINT TAB(18);"CURRENT NUMBER OF RECORDS ON FILE =";CVI(KP$)-1;:IF CVI(KP$)<1 THEN COLOR 0,7:PRINT"PLEASE INITIALIZE!":COLOR 7,0:PRINT:ELSE PRINT:PRINT
  11. 185 PRINT"Please depress the key corresponding to your choice."
  12. 1000 CLS:'BEGIN ENTRY
  13. 1005 FC=FC+1
  14. 10000 'BEGIN FILE LOOK UP
  15. 10010 GOSUB 27000:'TRY TO FIND THE RECORD
  16. 10200 GOSUB 28000:'UNPACK THE RECORD
  17. 10800 GOSUB 29000:'DISPLAY THE RECORD IF KEY FIELD MATCHES
  18. 11000 'BEGIN UPDATE
  19. 11010 GOSUB 27000:'TRY TO FIND THE RECORD
  20. 11200 GOSUB 28000:'UNPACK THE RECORD
  21. 11800 GOSUB 29000:'DISPLAY THE RECORD IF KEY FIELD MATCHES
  22. 11810 UF$="":LOCATE 25,1:PRINT"Which field number do you want to update? ";
  23. 11820 UX$=INPUT$(1):IF UX$>="0" AND UX$<="9" THEN PRINT UX$;:UF$=UF$+UX$:GOTO 11820:ELSE IF UX$=CHR$(8) THEN PRINT UX$;:UF$=LEFT$(UF$,LEN(UF$)-1):GOTO 11820:ELSE IF UX$<>CHR$(13) THEN 11820:ELSE UF=VAL(UF$)
  24. 11900 'BEGIN OUTPUT
  25. 11998 'INSERT CHANGED FIELDS AND SEND OUTPUT TO DISK
  26. 12000 'BEGIN RECORD DELETE
  27. 12010 GOSUB 27000:'TRY TO FIND THE RECORD
  28. 12200 GOSUB 28000:'UNPACK THE RECORD
  29. 12800 GOSUB 29000:'DISPLAY THE RECORD IF THE KEY FIELD MATCHES
  30. 12900 'DELETE CODE WRITTEN INTO ALL FIELDS
  31. 22000 'FIELD TITLES FOR DISPLAY
  32. 25000 IF ERR=6 THEN RESUME NEXT:ELSE IF ERR=5 AND (ERL>35000 AND ERL<36000) THEN RESUME 35000
  33. 25001 IF ERR=62 THEN LOCATE 25,1:COLOR 7,0:PRINT"YOU DIDN'T INITIALIZE YOUR KEY FILE! DO SO!";:COLOR 0,7:BEEP:FOR I=1 TO 2000:NEXT:CLOSE:RUN:ELSE X=CSRLIN:Y=POS(9)
  34. 25010 LOCATE 24,1:COLOR 23,0:PRINT"ERROR ENCOUNTERED IN LINE";ERL;:COLOR 7,0
  35. 25015 IF ERR=10 THEN PRINT"Number too large for field type.":LOCATE X,Y:RESUME NEXT
  36. 25020 IF ERL<10000 AND ERL>1000 THEN PRINT"Probable error in edit specifications.":PRINT"Error number is";ERR;". Please correct the syntax in line";ERL
  37. 25030 CLOSE:END
  38. 25999 'HASHING ALGORITHM
  39. 26000 FOR ZZ=1 TO LEN(ZZ$)
  40. 26010 SP=ASC(MID$(ZZ$,ZZ,1)):X#=X#+ZZ*(SP+1/SP)
  41. 26020 NEXT
  42. 26030 IF X#<1E+17 THEN X#=X#*X#:GOTO 26030
  43. 26035 SP=ASC(ZZ$)+ASC(RIGHT$(ZZ$,1)):SP=SP MOD 10:SP=SP+4:X$=STR$(X#):RP=VAL(MID$(X$,SP,4)):X#=0
  44. 27000 'LOOK FOR THE RECORD
  45. 27020 'NOW WE HAVE INPUT THE KEY FIELD
  46. 27030 ZZ$=KF$:GOSUB 26000:KP=RP:'GO TO HASHING ROUTINE AND GET POSITION
  47. 27999 'UNPACK FIELDS IN RECORD
  48. 28998 RETURN
  49. 28999 'DISPLAY FOUND RECORD
  50. 29000 CLS:CL=CSRLIN
  51. 29020 READ R$:CX=LEN(G$(I))
  52. 29021 WHILE (LEN(G$(I))>10 AND MID$(G$(I),CX,1)<=" " AND CX>10):CX=CX-1:WEND
  53. 29022 IF CX<LEN(G$(I)) THEN G$(I)=LEFT$(G$(I),CX)
  54. 29024 LC=POS(0):IF LC<5 THEN PRINT"#";I;:COLOR 0,7:PRINT R$;:COLOR 7,0:PRINT G$(I);:GOTO 29030
  55. 29025 CL=CSRLIN:IF CL>22 THEN GOSUB 41010:GOTO 29024
  56. 29026 IF (LC<40 AND LEN(R$)+LEN(G$(I))+36<80) THEN PRINT TAB(40);"#";I;:COLOR 0,7:PRINT R$;:COLOR 7,0:PRINT G$(I);:ELSE PRINT:GOTO 29024
  57. 29030 NEXT:RESTORE:PRINT
  58. 29930 IF AN$="S" THEN RETURN
  59. 29940 LOCATE 25,1:PRINT STRING$(79,32);:LOCATE 25,1:PRINT"Is this the record? Depress Y if so, any other if not.";
  60. 29950 AN$=INPUT$(1):LOCATE 25,1:PRINT STRING$(79,32);:LOCATE 25,1:IF AN$<>"Y" THEN GOSUB 27040:GOSUB 28000:GOTO 29000
  61. 29960 RETURN
  62. 29999 'NUMERIC FIELD EDIT CHECK SUBROUTINE
  63. 30000 CD=INSTR(CD$,CHR$(32)):IF CD>1 THEN CD$=LEFT$(CD$,CD-1)+MID$(CD$,CD+1):GOTO 30000:ELSE IF CD=1 THEN CD$=MID$(CD$,2):GOTO 30000
  64. 30005 FOR ZZ=1 TO LEN(CD$)
  65. 30010 IF MID$(CD$,ZZ,1)<"0" OR MID$(CD$,ZZ,1)>"9" THEN IF MID$(CD$,ZZ,1)<>"." AND MID$(CD$,ZZ,1)<>"-" THEN E=1
  66. 30020 NEXT:IF E THEN RETURN
  67. 30030 CD=INSTR(CD$,"-"):IF CD>0 AND INSTR(CD+1,CD$,"-")>0 THEN E=1:RETURN:ELSE IF (CD>0 AND CD<>1) THEN E=1:RETURN
  68. 30040 CD=INSTR(CD$,"."):IF CD>0 AND INSTR(CD+1,CD$,".")>0 THEN E=1:RETURN
  69. 30050 RETURN
  70. 30999 'ALPHA FIELD EDIT CHECK
  71. 31000 FOR ZZ=1 TO LEN(CD$)
  72. 31010 IF MID$(CD$,ZZ,1)<="9" AND MID$(CD$,ZZ,1)>="0" THEN E=1
  73. 31020 NEXT
  74. 31030 RETURN
  75. 32000 'INITIALIZE
  76. 32010 PRINT TAB(13);:COLOR 0,7:PRINT"This will erase all previous data, if any!":COLOR 7,0:PRINT TAB(13);"To continue initialization, depress the C key. ";
  77. 32030 AN$=INPUT$(1):IF AN$<>"C" THEN CLOSE:RUN
  78. 32035 CLS:PRINT"This will take a little time. Please be patient.":LOCATE 4,10:PRINT"INITIALIZING THROUGH RECORD"
  79. 32060 PUT 2,I
  80. 32070 LOCATE 5,20:PRINT I;:NEXT:LSET KP$=MKI$(1):PUT 2,1:CLOSE:RUN
  81. 34999 'BEGIN RECORD SCAN
  82. 35001 INPUT"Numeric or alphabetic scan (N/A): ";NS$:NS%=ASC(NS$):NS%=NS% AND 95:NS$=CHR$(NS%):IF NS$<>"N" AND NS$<>"A" THEN 35001
  83. 35002 INPUT"Smallest (numeric or alpha) to display: ";SM$
  84. 35003 INPUT"Largest (numeric or alpha) to display: ";LA$
  85. 35004 INPUT"Should I delay after displaying each record (Y/N)";DY$:NS%=ASC(DY$):NS%=NS% AND 95:DY$=CHR$(NS%):IF DY$<>"N" AND DY$<>"Y" THEN 35004
  86. 35050 GOSUB 28000:'UNPACK THE RECORD
  87. 35060 IF NS$="A" AND (G$(NS)<SM$ OR G$(NS)>LA$) THEN 35990
  88. 35070 IF NS$="N" AND (VAL(G$(NS))<VAL(SM$) OR VAL(G$(NS))>VAL(LA$)) THEN 35990
  89. 35960 GOSUB 29000:'DISPLAY THE RECORD
  90. 35965 IF DY$="Y" THEN 35970 ELSE 35990
  91. 35970 FOR J=1 TO 2000:NEXT:'WAIT BEFORE DISPLAYING NEXT RECORD
  92. 36000 'FIELD LENGTHS AND FIELDING THE FILE
  93. 36820 FIELD #1,CD% AS DD$,F%(ZZ) AS F$(ZZ):CD%=CD%+F%(ZZ):NEXT:RETURN
  94. 38000 CLOSE:NEW
  95. 40000 G1=INSTR(G$(UF),"MORE"):IF G1>0 THEN G%=CINT(VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G%),FIX(2+SGN(G%)/2)):RETURN
  96. 40010 G1=INSTR(G$(UF),"LESS"):IF G1>0 THEN G!=CSNG(-VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G!),FIX(2+SGN(G!)/2)):RETURN
  97. 40020 G1=INSTR(G$(UF),"+"):IF G1>1 THEN G%=CINT(VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G%),FIX(2+SGN(G%)/2)):RETURN
  98. 40030 G1=INSTR(G$(UF),"-"):IF G1>1 THEN G!=CSNG(-VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G!),FIX(2+SGN(G!)/2)):RETURN
  99. 40040 G1=INSTR(G$(UF),"*"):IF G1>1 THEN G%=CINT(VAL(G$(UF))*VAL(G$)):G$(UF)=MID$(STR$(G%),FIX(2+SGN(G%)/2)):RETURN
  100. 40050 G1=INSTR(G$(UF),"/"):IF G1>0 THEN G%=CINT(VAL(G$)/VAL(G$(UF))):G$(UF)=MID$(STR$(G%),FIX(2+SGN(G%)/2)):RETURN
  101. 40100 RETURN
  102. 40500 G3=0:G2=INSTR(G$(UF),"RO"):IF G2 THEN G3=VAL(MID$(G$(UF),G2+2))
  103. 40510 G1=INSTR(G$(UF),"MORE"):IF G1>0 THEN G#=CDBL(VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  104. 40520 G1=INSTR(G$(UF),"LESS"):IF G1>0 THEN G#=CDBL(-VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  105. 40530 G1=INSTR(G$(UF),"+"):IF G1>1 THEN G#=CDBL(VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  106. 40540 G1=INSTR(G$(UF),"-"):IF G1>1 THEN G#=CDBL(-VAL(G$(UF))+VAL(G$)):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  107. 40550 G1=INSTR(G$(UF),"*"):IF G1>1 THEN G#=CDBL(VAL(G$(UF))*VAL(G$)):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  108. 40560 G1=INSTR(G$(UF),"/"):IF G1>0 THEN G#=CDBL(VAL(G$)/VAL(G$(UF))):G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2))
  109. 40570 IF G2<1 THEN RETURN
  110. 40580 G#=CDBL(VAL(G$(UF)))
  111. 40590 IF G3 THEN FOR G2=1 TO G3:G#=G#*10:NEXT:G#=FIX(G#+.500001#*SGN(G#))
  112. 40600 IF G3 THEN FOR G2=1 TO G3:G#=G#/10:NEXT:ELSE G#=FIX(VAL(G$)+.500001#*SGN(G#))
  113. 40610 G$(UF)=MID$(STR$(G#),FIX(2+SGN(G#)/2)):RETURN
  114. 41000 IF CL<23 THEN RETURN
  115. 41010 LOCATE 25,1:COLOR 23,0:PRINT"THERE ARE MORE FIELDS. DEPRESS ANY KEY TO SEE THE REST.";:COLOR 7,0
  116. 41015 Y$=INPUT$(1):CLS:CL=0:RETURN
  117. 25,1:COLOR 23,0:PRINT"THERE ARE MORE FIELDS. DEPRESS ANY KEY TO SEE THE REST.";:COLOR 7,0
  118. 41015 Y$=INPUT$(1):CLS: