home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1994 #1 / monster.zip / monster / PROG_BAS / PRO98SRC.ZIP / DATABASE.BAS < prev    next >
BASIC Source File  |  1994-01-02  |  19KB  |  615 lines
  1. $IF NOT %NODBASE
  2. '=========================================================================
  3. '         dBASE III Plus file interface subroutines begin here
  4. '=========================================================================
  5. SUB dBSetIndexTo(IX$,Fld$,e%)
  6. e%=0
  7. ' Make sure a database is open
  8. IF dBASEOpen%=0 THEN e%=1:EXIT SUB
  9.  
  10. ' close existing index if it is open
  11. IF IX$="" OR Index$<>"" THEN Index$="":_
  12.    CALL BT("","Q","","","","",r%)
  13. IF IX$="" THEN EXIT SUB
  14. ' verify filename exists
  15. IF DIR$(IX$)="" THEN e%=3:EXIT SUB
  16.  
  17. ' verify field exists in database
  18. Fld%=0:Fld$=UCASE$(Fld$)
  19.     FOR y%=1 TO NumberOfFields?
  20.             IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
  21.     NEXT y%
  22. IF Fld%=0 THEN e%=2:EXIT SUB
  23. Index$=IX$:IndexField$=Fld$:IndexField?=Fld%
  24. END SUB
  25.  
  26. SUB dBCreateIndex(IX$, Fld$, e%)
  27. REDIM K$(1000), D$(1000)
  28. Bt.Update.Always%=0
  29. ' Make sure a database is open
  30. IF dBASEOpen%=0 THEN e%=1:GOTO ExitSub
  31.  
  32. ' close existing index if it is open
  33. IF IX$="" OR Index$<>"" THEN Index$="":_
  34.    CALL BT("","Q","","","","",r%)
  35. IF IX$="" THEN EXIT SUB
  36.  
  37. ' verify field exists in database
  38. Fld%=0:Fld$=UCASE$(Fld$)
  39.     FOR y%=1 TO NumberOfFields?
  40.             IF INSTR(DBS(y%).FieldName,Fld$)=1 THEN Fld%=y%:EXIT FOR
  41.     NEXT y%
  42. IF Fld%=0 THEN e%=2:GOTO EXITSUB
  43. Index$=IX$:IndexField$=Fld$:IndexField?=Fld%
  44.  
  45. ' Create the index and build it.
  46. K$=SPACE$(DBS(Fld%).FieldLength):D$=CHR$(0,0,0,0)
  47. CALL BT(Index$,"C",K$,D$,RK$,RD$,R%)
  48. IF NOT R% THEN E%=3:GOTO EXITSUB ' could not create index
  49. x%=CSRLIN:y%=POS(0)
  50. For y???=1 TO NumberOfRecords???
  51.     dBGetRecord Y???, e%
  52.         IF e% THEN e%=4:EXIT FOR
  53.         IF INSTAT OR COMCHARS% THEN A$=PROZOINKEY$:IF A$=CHR$(27) THEN e%=5:EXIT FOR
  54.  
  55.         ' ====================
  56.         ' remove the UCASE$ here if you do not want the index to be
  57.         ' create as case insensative.
  58.         K$=UCASE$(dBGetCField$(Indexfield$, e%))
  59.         '  ^^^^^^____________________________ ^
  60.  
  61.         IF e% THEN e%=6:EXIT FOR
  62.         D$=MKDWD$(Y???)  ' must know the record number!
  63.         INCR i%
  64.         K$(i%)=K$:D$(i%)=D$
  65.         IF i%=1000 THEN
  66.             FOR ii%=1 TO 1000
  67.         CALL BT(Index$,"A",K$(ii%),D$(ii%),RK$,RD$,r%)
  68.             IF NOT r% THEN e%=7:EXIT FOR
  69.                 NEXT ii%
  70.                 i%=0
  71.                 IF e%=7 THEN EXIT FOR
  72.     END IF
  73.         IF TTY=0 THEN PROZOPRINT "@SCP()"+STR$(Y???)+"@RCP()" ELSE PROZOPRINT "."
  74.         NEXT y???
  75.  
  76.             FOR ii%=1 TO i%
  77.         CALL BT(Index$,"A",K$(ii%),D$(ii%),RK$,RD$,r%)
  78.             IF NOT r% THEN e%=7:EXIT FOR
  79.                 NEXT ii%
  80.  
  81.     CALL BT(Index$,"Q","","","","",r%)
  82. ExitSub:
  83. BT.Update.Always%=-1
  84. END SUB
  85.  
  86. SUB dBSearchIndex(Findme$,e%)
  87. e%=0
  88. IF dBaseOpen%=0 THEN e%=1:EXIT SUB
  89. IF Index$="" THEN
  90.         PROZOPRINT CrLf$+"Index not open, scan database? (Y/N): "
  91.         YN$=PROZOINPUT$
  92.     IF UCASE$(YN$)="Y" THEN
  93.         ' scan the whole database for a match
  94.         FOR y???=1 TO NumberOfRecords???
  95.                 dBGetRecord y???, e%
  96.                     IF e% THEN EXIT FOR
  97.                     IF INSTR(FindMe$,RecordBlock$) THEN EXIT FOR
  98.         NEXT y???
  99.         IF y???=>NumberOfRecords THEN _
  100.                 PROZOPRINT "Not Found.  Press a key..."
  101.                 CWAIT
  102.                 PROZOPRINT CrLf$
  103.         END IF
  104. ELSE
  105.         Findme$=UCASE$(Findme$)
  106.     CALL BT(Index$,"S", Findme$, D$, RK$, RD$, r%)
  107.         'IF NOT r% THEN e%=2:EXIT SUB
  108.         FindMe$=RK$
  109.         R???=CVDWD(RD$)
  110.         IF R???>0 THEN CALL dBGetRecord(R???,e%)
  111. END IF
  112. END SUB
  113.  
  114. SUB dBSkip(NS%, e%)
  115. e%=0
  116. IF LEN(INDEX$) THEN
  117.         DO
  118.     IF NS%<0 THEN BT Index$,"P","","",K$,D$,r%:INCR NS% ELSE _
  119.                       BT Index$,"N","","",K$,D$,r%:DECR NS%
  120.         IF NOT r% THEN e%=-1:EXIT SUB
  121.         IF INSTAT THEN IF A$=CHR$(27) THEN NS%=0
  122.         LOOP WHILE NS%<>0
  123.         dBGetRecord CVDWD(D$), e%
  124. ELSE
  125.     RN???=RecNum??? + NS%
  126.         IF RN??? < 1 THEN RN???=1:e%=-1
  127.         IF RN??? > NumberOfRecords??? THEN RN???=NumberOfRecords???:e%=-1
  128.         dBGetRecord RN???,e%
  129. END IF
  130. END SUB
  131.  
  132. SUB dBGotoTop (e%)
  133. e%=0
  134. IF LEN(INDEX$) THEN
  135.     BT Index$,"F","","",K$,D$,r%
  136.         IF NOT r% THEN e%=-2:EXIT SUB
  137.         DBGetRecord CVDWD(D$),e%
  138. ELSE
  139.     DBGetRecord 1, e%
  140. END IF
  141. END SUB
  142.  
  143. SUB dBGotoBottom (e%)
  144. e%=0
  145. IF LEN(INDEX$) THEN
  146.     BT Index$,"L","","",K$,D$,r%
  147.         IF NOT r% THEN e%=-2:EXIT SUB
  148.         DBGetRecord CVDWD(D$),e%
  149. ELSE
  150.     DBGetRecord NumberOfRecords???, e%
  151. END IF
  152. END SUB
  153.  
  154. SUB dBEditRecord (RN???, e%)
  155. e%=0
  156.     dBGetRecord RN???, e%
  157.         IF e% THEN EXIT SUB
  158.  
  159. ' remove entry from index
  160. IF LEN(INDEX$) THEN
  161.     BT Index$,"D",UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
  162.         IF NOT r% THEN PROZOPRINT "Error accessing index file"+CrLf$
  163. END IF
  164.  
  165.         ' edit the record
  166.         DBEditFields e%
  167.  
  168. ' replace entry in index
  169. IF LEN(INDEX$) THEN
  170.     BT Index$,"A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RN???),"","",r%
  171.         IF NOT r% THEN PROZOPRINT "Error updating index file"+CrLf$
  172. END IF
  173. END SUB
  174.  
  175. SUB dBAppendRecord (e%)
  176.     e%=0
  177.         IF dBaseOpen%=0 THEN e%=1:EXIT SUB
  178.     Recnum???=0
  179.         RecordBlock$=SPACE$(LEN(RecordBlock$))
  180.     DbEditFields e%
  181.     IF Recnum???>0 AND LEN(INDEX$) THEN
  182.             BT Index$, "A", UCASE$(DBGetCField$(IndexField$,e%)),MKDWD$(RecNum???),"","",r%
  183.                 IF NOT r% THEN PROZOPRINT "Error appending index file."+CrLf$
  184.         END IF
  185. END SUB
  186.  
  187. SUB dBDefaultFormat
  188. ' Create a default field edit format.
  189. IF dBaseOpen%=0 THEN EXIT SUB
  190. ERASE DBE()
  191. k%=1
  192. FOR y%=1 to NumberOfFields?
  193.         INCR j%:IF j%=20 THEN j%=1:k%=k%+40:IF K%=81 THEN EXIT FOR
  194.     DBE(y%).FieldName = DBS(y%).FieldName
  195.         DBE(y%).FieldType = DBS(y%).FieldType
  196.         DBE(y%).FieldLength = DBS(y%).FieldLength
  197.         DBE(y%).FieldRow = j%
  198.         DBE(y%).FieldCol = k%+(11-LEN(RTRIM$(DBS(y%).FieldName,CHR$(0))))
  199.     DBE(y%).FieldFG = 0
  200.         DBE(y%).FieldBG = 7
  201. NEXT y%
  202. END SUB
  203.  
  204. SUB dBCreateFormat
  205. IF dBaseOpen%=0 THEN PROZOPRINT "No Database is in USE."+CrLf$:EXIT SUB
  206. DO
  207. PROZOCLS
  208. dbdefaultformat
  209. DBView
  210. PROZOLOCATE 23,1:PROZOCOLOR 7,0:PROZOPRINT "Press ENTER to Accept or Fieldname to change: "
  211. F$=PROZOINPUT$
  212. IF F$="" THEN
  213.     B%=FREEFILE
  214.         PROZOLOCATE 23,1:PROZOPRINT SPACE$(80)
  215.         PROZOLOCATE 23,1:PROZOPRINT "Enter format filename: "
  216.         F$=PROZOINPUT$
  217.         IF F$="" THEN F$="NONAME.FMT"
  218.         OPEN F$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
  219.         Fld%=1
  220.         DO UNTIL DBE(Fld%).FieldLength=0
  221.             PUT #B%, Fld%, DBE(Fld%)
  222.                 INCR Fld%
  223.         LOOP
  224.         EXIT LOOP
  225. ELSE
  226. Fld%=0
  227. F$=UCASE$(F$)
  228.     FOR y%=1 TO NumberOfFields?
  229.             IF INSTR(DBS(y%).FieldName,F$)=1 THEN Fld%=y%:EXIT FOR
  230.     NEXT y%
  231. IF Fld%=0 THEN PROZOLOCATE 23,1:PROZOPRINT SPACE$(80):PROZOLOCATE 23,1:PROZOPRINT "BAD FIELD NAME":SOUND 50,4:DELAY 2:ITERATE LOOP
  232. PROZOLOCATE 23,1:PROZOPRINT SPACE$(80):PROZOLOCATE 23,1:PROZOPRINT "Use arrow keys to place new field position"
  233. X%=DBE(Fld%).FieldRow
  234. Y%=DBE(Fld%).FieldCol
  235. F$=RTRIM$(DBE(Fld%).FieldName,CHR$(0))+":"+STRING$(DBE(Fld%).FieldLength,176)
  236. ' edit field location
  237. DBSCRNFIND X%, Y%, F$
  238. IF X%=0 THEN EXIT LOOP
  239. DBE(Fld%).FieldRow = X%
  240. DBE(Fld%).FieldCol = Y%
  241. END IF
  242. LOOP
  243. END SUB
  244.  
  245. SUB dBSetFormatTo(FormatFileName$,Ecode%)
  246. Ecode%=0
  247. IF FormatFileName$="" THEN ERASE DBE():EXIT SUB
  248. IF Dir$(FormatFileName$)="" THEN Ecode%=1:EXIT SUB
  249. B%=FREEFILE
  250. OPEN FormatFileName$ FOR RANDOM SHARED AS #B% LEN=LEN(DBE(1))
  251. FOR y%=1 TO LOF(B%)\LEN(DBE)
  252.     GET #B%, y%, DBE(y%)
  253. NEXT y%
  254. CLOSE #B%
  255. END SUB
  256.  
  257. SUB dBView
  258. Fld%=1
  259. of%=(PBVScrnTxtAttr AND &HF) ' get the original foreground and background
  260. ob%=(PBVScrnTxtAttr \ &H10)  ' PROZOCOLORs, in case they change.
  261. DO UNTIL DBE(Fld%).FieldLength=0
  262.         PROZOLOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol
  263.         PROZOCOLOR of%,ob%
  264.         PROZOPRINT RTRIM$(DBE(Fld%).FieldName,chr$(0))+":"
  265.         PROZOPRINT "@SCP()"
  266.         PROZOCOLOR DBE(Fld%).FieldFG,DBE(Fld%).FieldBG
  267.         PROZOPRINT SPACE$(DBE(Fld%).FieldLength)
  268.         PROZOPRINT "@RCP()"
  269.         IF DBE(Fld%).FieldType="N" THEN
  270.                 PROZOPRINT LTRIM$(STR$(dBGetNField!((DBE(Fld%).FieldName),E%)))
  271.                 IF E% THEN PROZOPRINT "???"
  272.     ELSE
  273.                 PROZOPRINT dBGetCField$((DBE(Fld%).FieldName),E%)
  274.                 IF E% THEN PROZOPRINT "???"
  275.     END IF
  276.     INCR Fld%
  277. LOOP
  278. PROZOCOLOR of%, ob%
  279. END SUB
  280.  
  281.  
  282. SUB dBEditFields(Ecode%)
  283. Ecode%=0
  284. Fld%=1 ' start with the first field on the screen
  285. of%=(PBVScrnTxtAttr AND &HF) ' get the original foreground and background
  286. ob%=(PBVScrnTxtAttr \ &H10)  ' PROZOCOLORs, in case they change.
  287. ' Now make one pass and DRAW the fields on the screen with defaults
  288. DO UNTIL DBE(Fld%).FieldLength=0
  289.         PROZOLOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol
  290.         PROZOCOLOR of%,ob%
  291.         PROZOPRINT RTRIM$(DBE(Fld%).FieldName,chr$(0))+":"
  292.         PROZOPRINT "@SCP()"
  293.         PROZOCOLOR DBE(Fld%).FieldFG,DBE(Fld%).FieldBG
  294.         PROZOPRINT SPACE$(DBE(Fld%).FieldLength)
  295.         PROZOPRINT "@RCP()"
  296.         IF DBE(Fld%).FieldType="N" THEN
  297.                 PROZOPRINT LTRIM$(STR$(dBGetNField!((DBE(Fld%).FieldName),E%)))
  298.                 IF E% THEN PROZOPRINT "???"
  299.     ELSE
  300.                 PROZOPRINT dBGetCField$((DBE(Fld%).FieldName),E%)
  301.                 IF E% THEN PROZOPRINT "???"
  302.     END IF
  303.  
  304.     INCR Fld%
  305. LOOP
  306.  
  307.  
  308. Fld%=1 ' start with the first field on the screen
  309. ' Now go back and edit the fields
  310. DO UNTIL DBE(Fld%).FieldLength=0
  311.         PROZOLOCATE DBE(Fld%).FieldRow,DBE(Fld%).FieldCol
  312.         PROZOCOLOR of%,ob%
  313.         PROZOPRINT RTRIM$(DBE(Fld%).FieldName,CHR$(0))+":"
  314.         r%=PROZOCSRLIN:C%=PROZOPOS
  315.         IF DBE(Fld%).FieldType="N" THEN
  316.                 num%=-1
  317.             ED$=LTRIM$(STR$(dBGetNField!((DBE(Fld%).FieldName),E%)))
  318.                 IF E% THEN ED$="???"
  319.                     ELSE
  320.                 num%=0
  321.             ED$= dBGetCField$((DBE(Fld%).FieldName),E%)
  322.                 IF E% THEN ED$="???"
  323.     END IF
  324.  
  325.         ED$=DBGET$(r%, c%, (DBE(Fld%).FieldLength), (DBE(Fld%).FieldFG),_
  326.                   (DBE(Fld%).FieldBG), ED$, -1, num%,KeyFlag%)
  327.  
  328.         IF num% THEN
  329.             dBPutNField (DBE(Fld%).FieldName), VAL(ED$), E%
  330.         ELSE
  331.             dBPutCField (DBE(Fld%).FieldName),ED$,E%
  332.     END IF
  333.  
  334.     SELECT CASE KeyFlag%
  335.             CASE 10
  336.                     DBPutRecord RecNum???, E%
  337.                         EXIT LOOP
  338.         CASE 5
  339.                     EXIT LOOP
  340.         CASE 0,2,6
  341.                     INCR Fld%
  342.                         IF Fld%>NumberOfFields? THEN
  343.                             DBPutRecord RecNum???,e%
  344.                                 EXIT LOOP
  345.                                 END IF
  346.                                 'Fld%=NumberOfFields?
  347.                 CASE 4,8
  348.                     DECR Fld%
  349.                         IF Fld%=0 THEN Fld%=1
  350.         END SELECT
  351. LOOP
  352. PROZOCOLOR Of%, Ob%
  353.  
  354. END SUB
  355.  
  356.  
  357.  
  358. SUB dBPutCField(FieldName$, FieldData$, Ecode%)
  359. Ecode% = 1
  360.     FieldName$=UCASE$(FieldName$)
  361. FOR nof? = 1 TO NumberOfFields?
  362.     IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
  363.                 IF LEN(FieldData$)>DBS(nof?).FieldLength THEN FieldData$=LEFT$(FieldData$,DBS(nof?).FieldLength)
  364.         MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  365.         DBS(nof?).FieldLength) = FieldData$ + _
  366.                 Space$(DBS(nof?).FieldLength-LEN(FieldData$))
  367.         Ecode% = 0
  368.         EXIT FOR
  369.     END IF
  370. NEXT nof?
  371. END SUB
  372.  
  373. SUB dBPutNField(FieldName$, FieldData!, Ecode%)
  374.     Ecode% = 1
  375.     FieldName$=UCASE$(FieldName$)
  376.  
  377. FOR nof? = 1 TO NumberOfFields?
  378.     IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
  379.     Pattern$ = STRING$(DBS(nof?).FieldLength,"#")
  380.     IF DBS(nof?).FieldDecimals > 0 THEN
  381.     MID$(Pattern$,LEN(Pattern$)-(DBS(nof?).FieldDecimals),1)="."
  382.     END IF
  383.     FieldData$ = USING$(Pattern$,FieldData!)
  384.     MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  385.     DBS(nof?).FieldLength) = FieldData$
  386.         Ecode% = 0
  387.         EXIT FOR
  388.     END IF
  389. NEXT nof?
  390.  
  391. END SUB
  392.  
  393.  
  394. SUB dBPutRecord(RN???,Ecode%)
  395. Ecode% = 0
  396. IF dBaseOpen% = 0 THEN Ecode% = 1: Exit Sub
  397.                          ' Error Code 1 = Database file not open
  398. GET #dBaseOpen%, 1, DBH
  399. IF RN??? > DBH.NumberOfRecords + 1 THEN RN???=0
  400. IF RN???<1 OR RN???=DBH.NumberOfRecords+1 THEN RN???=DBH.NumberOfRecords+1 :_
  401.  DBH.NumberOfRecords = RN???:LastRec%=1: NumberOfRecords???=RN???
  402. R$=MID$(RecordBlock$,2)
  403. IF LEN(R$)<DBH.Size+1 THEN R$=R$+SPACE$(DBH.Size+1-LEN(R$))
  404. IF LastRec%=1 THEN R$=R$+CHR$(26)
  405. PUT #dBaseOpen%, DBH.offset + ((RN??? * DBH.Size) - DBH.Size)+1 , R$
  406. IF DBH.NumberOfRecords = RN??? THEN _
  407.           e$ = CHR$(26) + CHR$(10): PUT #dBaseOpen%, SEEK(dBaseOpen%) + 1, e$
  408. DBH.Day   = VAL(MID$(DATE$, 4, 2))
  409. DBH.Month = VAL(LEFT$(DATE$, 2))
  410. DBH.Year  = VAL(RIGHT$(DATE$, 2))
  411.  
  412. PUT #dBaseOpen%, 1, DBH
  413. RecNum???=RN???
  414. END SUB
  415.  
  416.  
  417. SUB dBGetARRAY(DB$(),Ecode%)
  418.  
  419. IF UBOUND(DB$()) < NumberOfFields? THEN Ecode% = 1:EXIT SUB
  420.                     ' Error code 1, array not big enough
  421. FOR nof? = 1 TO NumberOfFields?
  422.     IF INSTR("CLD",DBS(nof?).FieldType) THEN
  423.         DB$(nof?) = MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  424.         DBS(nof?).FieldLength)
  425.     ELSE
  426.         DB$(nof?) = STR$(val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  427.      DBS(nof?).FieldLength)) * (10 ^ DBS(nof?).FieldDecimals))
  428.     END IF
  429. NEXT nof?
  430. END SUB
  431.  
  432.  
  433.  
  434. FUNCTION dBGetASCII$
  435. A$=""
  436. FOR nof? = 1 TO NumberOfFields?
  437.     IF INSTR("CLD",DBS(nof?).FieldType) THEN
  438.         A$ = A$ + CHR$(34)+MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  439.         DBS(nof?).FieldLength)+CHR$(34)
  440.     ELSE
  441.         A$ = A$ + STR$(val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  442.      DBS(nof?).FieldLength)) * (10 ^ DBS(nof?).FieldDecimals))
  443.     END IF
  444.     IF nof? < NumberOfFields? THEN A$ = A$ + ","
  445. NEXT nof?
  446. dBGetASCII$ = A$
  447. END FUNCTION
  448.  
  449.  
  450.  
  451.  
  452. FUNCTION dBGetCField$ (FieldName$, Ecode%)
  453. Ecode% = 1
  454.     FieldName$=UCASE$(FieldName$)
  455. FOR nof? = 1 TO NumberOfFields?
  456.     IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
  457.         dBGetCField$ = MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  458.         DBS(nof?).FieldLength)
  459.         Ecode% = 0
  460.         EXIT FOR
  461.     END IF
  462. NEXT nof?
  463. END FUNCTION
  464.  
  465. FUNCTION dBGetNField!(FieldName$,Ecode%)
  466.     Ecode% = 1
  467.     FieldName$=UCASE$(FieldName$)
  468. FOR nof? = 1 TO NumberOfFields?
  469.     IF LEFT$(DBS(nof?).FieldName,LEN(FieldName$)) = FieldName$ THEN
  470.     dBGetNField! = val(MID$(RecordBlock$, DBS(nof?).Fieldoffset,_
  471.      DBS(nof?).FieldLength)) '* (10 ^ -DBS(nof?).FieldDecimals)
  472.         Ecode% = 0
  473.         EXIT FOR
  474.     END IF
  475. NEXT nof?
  476.  
  477. END FUNCTION
  478.  
  479.  
  480. SUB DBGetRecord (Rn???, Ecode%)
  481. Ecode% = 0
  482. IF dBaseOpen% = 0 THEN Ecode% = 1: EXIT SUB              ' database not open
  483. GET #dBaseOpen%, 1, DBH
  484. IF Rn??? > DBH.NumberOfRecords THEN Ecode% = 2: EXIT SUB   ' record too high
  485. IF Rn??? < 1 THEN Ecode% = 2: EXIT SUB                     ' record too low
  486.  
  487. SEEK #dBaseOpen%, DBH.offset + (Rn??? * DBH.Size) - DBH.Size
  488. GET$ dBaseOpen%, DBH.Size + 2, RecordBlock$
  489. RecNum???=RN???
  490. END SUB  ' dBGetRecord
  491.  
  492.  
  493.  
  494. SUB dBUse (FileName$, Ecode%)
  495. Ecode% = 0: Recnum??? = 0
  496. IF dBaseOpen% THEN CLOSE #dBaseOpen%: dBaseOpen% = 0
  497.                                   'if database file is open, then close it.
  498. FileName$ = UCASE$(FileName$)
  499. IF INSTR(FileName$, ".") = 0 THEN FileName$ = FileName$ + ".DBF"
  500. IF DIR$(FileName$) = "" THEN Ecode% = 1: EXIT SUB
  501.                                                   ' error 1=file not found
  502.  
  503. LET dBaseOpen% = 81
  504. OPEN FileName$ FOR BINARY ACCESS READ WRITE SHARED AS #dBaseOpen%
  505. IF LOF(dBaseOpen%) = 0 THEN CLOSE #dBaseOpen%:dBaseOpen%=0:Ecode%=2:EXIT SUB
  506.                                                 ' Error 2=file is 0 length
  507.  
  508. GET #dBaseOpen%, 1, DBH
  509. IF DBH.Year > 99 OR DBH.Month > 12 OR DBH.Month = 0 OR_
  510.    DBH.Day > 31 OR DBH.Day = 0 THEN CLOSE #dBaseOpen%:_
  511.    dBaseOpen% = 0: Ecode% = 4: EXIT SUB
  512.                                               ' Error 4 = not a dBASE file
  513.  
  514. ' establish number of fields by (dbh.offset-len(dbheader))\32
  515. NumberOfRecords??? = DBH.NumberOfRecords
  516. NumberOfFields? = (DBH.offset - LEN(DBH)) \ 32
  517. IF NumberOfFields?<1 THEN Ecode% = 3:CLOSE #dBaseOpen%:dBaseOpen%=0:Exit SUB
  518.                                 ' Error 3 = no fields in database structure
  519.  
  520.  
  521. ' Load the field definition header
  522. DBS(1).FieldOffset = 3
  523. FOR nof? = 1 TO NumberOfFields?
  524.     GET #dBaseOpen%, SEEK(dBaseOpen%), DBF
  525.  
  526.         DBS(nof?).FieldName     = DBF.FieldName
  527.         DBS(nof?).FieldType     = DBF.FieldType
  528.         DBS(nof?).FieldLength   = DBF.FLen
  529.         DBS(nof?+1).FieldOffset = DBS(nof?).FieldOffset + DBF.FLen
  530.         DBS(nof?).FieldDecimals = DBF.DecC
  531. NEXT nof?
  532. 'CALL dBDefaultFormat  ' set default screen format
  533. RecordBlock$=SPACE$(DBH.Size+2)
  534. END SUB 'dBUse
  535.  
  536. SUB DBSCRNFIND(X%, Y%, F$)
  537. IF ComLine THEN PROZOPRINT "Cannot design screens while on-line"+CrLf$:EXIT SUB
  538. 'arrows around F$ on the screen. and returns the ultimate coordinates.
  539. REG 1, 15*256
  540. CALL INTERRUPT &H10
  541. IF Reg(1) - (Reg(1)\256) * 256 = 7 THEN Address=&HB000 else Address=&HB800
  542. DEF SEG = ADDRESS
  543. O$=PEEK$(0,4000)
  544.  
  545. DO   ' a deer, a female deer
  546.     LOCATE X%, Y%:COLOR 20,0:PRINT F$;
  547.         COLOR 7,0
  548.         LOCATE 23,1:PRINT SPACE$(80);
  549.         LOCATE 23,1:PRINT "Use arrows to re-position field.  ENTER finishes, ESC aborts.";
  550.     KB$="" : WHILE KB$=""    ' create a polling loop instead of SLEEPing
  551.                 KB$=INKEY$
  552.         WEND
  553.         POKE$ 0,O$
  554.         SELECT CASE KB$
  555.  
  556.             CASE CHR$(0,71) '  home
  557.                             Y%=1
  558.             CASE CHR$(0,72) '  up arrow
  559.                             DECR X%:IF X%=0 THEN X%=22
  560.             CASE CHR$(0,73) '  page up
  561.                             X%=1
  562.             CASE CHR$(0,75) '  left arrow
  563.                             DECR Y%:IF Y%=0 THEN Y%=79-LEN(F$)
  564.             CASE CHR$(0,77) '  right arrow
  565.                             INCR Y%:IF Y%>79-LEN(F$) THEN Y%=1
  566.             CASE CHR$(0,79) '  end
  567.                             Y%=79-LEN(F$)
  568.             CASE CHR$(0,80) '  down arrow
  569.                             INCR X%:IF X%=23 THEN X%=1
  570.             CASE CHR$(0,81) '  page down
  571.                             X%=22
  572.             CASE CHR$(0,82) '  Insert
  573.             CASE CHR$(0,83) '  Delete
  574.             CASE CHR$(0,59) '  f1
  575.             CASE CHR$(0,60) '  f2
  576.             CASE CHR$(0,61) '  f3
  577.             CASE CHR$(0,62) '  f4
  578.             CASE CHR$(0,63) '  f5
  579.             CASE CHR$(0,64) '  f6
  580.             CASE CHR$(0,65) '  f7
  581.             CASE CHR$(0,66) '  f8
  582.             CASE CHR$(0,67) '  f9
  583.             CASE CHR$(0,68) '  f10
  584.                             FINISHED=-1
  585.             CASE CHR$(0,115) ' CTL-Left arrow
  586.                             Y%=Y%-8:IF Y%<1 THEN Y%=1
  587.             CASE CHR$(0,116) ' CTL-Right arrow
  588.                             Y%=Y%+8:IF Y%>79-LEN(F$) THEN y%=79-LEN(F$)
  589.             CASE CHR$(0,117) ' CTL-END
  590.                             FINISHED=-1
  591.             CASE CHR$(0,118) ' CTL-PgDn
  592.             CASE CHR$(0,119) ' CTL-HOME
  593.                             X%=1:Y%=1
  594.             CASE CHR$(0,132) ' CTL-PgUp
  595.             CASE CHR$(3)  '  CTL-C ETX
  596.                             X%=0:FINISHED=-1
  597.             CASE CHR$(9)  '  CTL-I TAB
  598.                             Y%=Y%+8:IF Y%>79-LEN(F$) THEN y%=79-LEN(F$)
  599.             CASE CHR$(13)  ' CTL-M CARRIAGE RETURN
  600.                             FINISHED=-1
  601.             CASE CHR$(16)  ' CTL-P DLE
  602.             CASE CHR$(21)  ' CTL-U NAK
  603.             CASE CHR$(27)  ' Escape ESC
  604.                             X%=0:FINISHED=-1
  605.  
  606.             END SELECT
  607.  
  608.  
  609. LOOP WHILE NOT FINISHED
  610. POKE$ 0, O$
  611. DEF SEG
  612.  
  613. END SUB
  614.  
  615. $ENDIF