Category : BASIC Source Code
Archive   : QB_DB3.ZIP
Filename : DB3DEMO.BAS

KEY OFF
CLS
DIM COL.%(40),ROW.%(40),LNG.%(40),DEC.%(40)
DIM NFD.%(40),NFL.%(40),NFR.%(40),NFU.%(40)
DIM DFA.$(40),LLA.$(40),ULA.$(40),IR.$(40)
DIM ICA.$(40),ICD.$(40),IPC.$(40),USER.$(40)
USER.$(1) = "CND"
LOCATE 12,20
PRINT "ARE YOU USING COLOR OR MONOCROME ?"
CALL BDTFIELD (54,12,1,0,"C",E.$,IP.$,"MC",LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
IF R.$ = "C" THEN
MENUFG%=0
MENUBG%=3
ELSE
MENUFG%=7
MENUBG%=9
END IF
DB.FX.% = 1
BARCODE$ = CHR$(35)+CHR$(33)+CHR$(19)
ESC% = 0
REM $DYNAMIC
DIM DB.NAME.$(50),DB.LENGTH.%(50),DB.TYPE.$(50),DB.DEC.%(50),DB.FIELD.$(50)
REM $STATIC
CLS

REM MENU FIELDS
MENULINE$=" HELP FILES RECORDS "
MENULINE$=MENULINE$+SPACE$(70-LEN(MENULINE$))

BLKSIZE%=10
BLKNUM%=3
DIM ITEMS$(3,9)
ITEMS$(1,1)="HELP"
MAXSIZE%(1)=4:MAXITEMS%(1)=2
ITEMS$(2,1)="USE ":ITEMS$(2,2)="CREATE "
ITEMS$(2,3)="STRUCTURE":ITEMS$(2,4)="QUIT "
MAXSIZE%(2)=9:MAXITEMS%(2)=4
ITEMS$(3,1)="APPEND ":ITEMS$(3,2)="EDIT ":ITEMS$(3,3)="BROWSE "
ITEMS$(3,4)="DELETE ":ITEMS$(3,5)="RECALL "::ITEMS$(3,6)="PACK "
MAXSIZE%(3)=8:MAXITEMS%(3)=6

MENUSLCT%=0
ITEMSLCT%=0
GOTO HELP

TRUE = -1
FALSE = 0
WHILE 1 = 1
MENULINE$=LEFT$(MENULINE$,70)
CALL FASTPRT(MENULINE$+TIME$+" ",1,1,48)
CALL BDTFIELD (79,1,1,D.%,ITC.$,E.$,IP.$,ITS.$,LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
SHOWMENU:
COLOR 7,1
MENUSLCT% = ESC% - 100
IF MENUSLCT% = 1 THEN GOTO HELP
IF MENUSLCT% > 0 THEN
CALL FASTPRT(MENULINE$+TIME$,1,1,113)
GOSUB MENU
GROW = 1
END IF
IF MENUSLCT% = 2 THEN ON ITEMSLCT% GOSUB OPENFILE,_
CREATEFILE,_
STRUCTURE,_
QUIT
IF MENUSLCT% = 3 THEN ON ITEMSLCT% GOSUB ADD,_
EDITREC,_
RETRIEVE,_
RECORD.DELETE,_
RECORD.RECALL,_
PACK
CLS
WEND

ADD:
CLS
MSG1$ = CHR$(24)+" Prior Field "+CHR$(25)+" Next Field"
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
COLOR 7,1
DB.NUM.% = DB.NUM.% + 1

GOSUB SCREENREC
FOR I = 1 TO DB.FIELDS.%
IF ICD.$(I) = "N" THEN
DB3.NUM.# = VAL(IR.$(I))
CALL DB3.NUM.STR(DB3.NUM.#,DB.DEC.%(I),DB.STR.NUM$)
RSET DB.FIELD.$(I) = IR.$(I)
ELSE
LSET DB.FIELD.$(I) = IR.$(I)
END IF

NEXT I

CALL DB.ADD(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
RETURN

EDITREC:
CLS
MSG1$ = CHR$(24)+" Prior Field "+CHR$(25)+" Next Field"
MSG2$ = "PgUp Prior Record PgDn Next Record"
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
COLOR 7,0
UPDATE = TRUE
GOSUB RETRIEVE
UPDATE = FALSE
RETURN

RETRIEVE:
IF ITEMSLCT% = 3 THEN
CLS
MSG1$ = "PgUp Prior Record PgDn Next Record"
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
END IF
DB.NUM.% = 1
CALL DB.GET(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
GOSUB SCREENREC
WHILE ESC% <> 1
IF DEL THEN
IF ESC% = 105 THEN _
CALL DB.DEL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
END IF
IF RECALL THEN
IF ESC% = 103 THEN _
CALL DB.RECALL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
END IF
IF UPDATE THEN
FOR I = 1 TO 10
IF IR.$(I) <> "" THEN
PUTREC = TRUE
LSET DB.FIELD.$(I) = IR.$(I)
END IF
NEXT I
IF PUTREC THEN _
CALL DB.PUT(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
END IF
IF ESC% = 9 THEN
DB.NUM.% = DB.NUM.% - 1
IF DB.NUM.% < 1 THEN DB.NUM.% = 1
END IF
IF ESC% = 3 THEN
DB.NUM.% = DB.NUM.% + 1
IF DB.NUM.% > DB.HDR.REC.TOT.! THEN DB.NUM.% = DB.HDR.REC.TOT.!
END IF
PUTREC = FALSE
CALL DB.GET(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
GOSUB SCREENREC
WEND
RETURN

RECORD.DELETE:
CLS
MSG1$ = "Alt+D To mark Record For Deletion"
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
DEL = TRUE
GOSUB RETRIEVE
DEL = FALSE
RETURN

PACK:
CALL DB.PACK(DB.FX.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
RETURN

RECORD.RECALL:
CLS
MSG1$ = "Alt+R To Recall Record"
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
RECALL = TRUE
GOSUB RETRIEVE
RECALL = FALSE
MSG$ = "Esc To Exit"
RETURN

OPENFILE:
CLS
MSG1$ = "Enter File Name Of Existing .DBF File"
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
DB.FX.% = 1
CALL FASTPRT("FILE NAME ==>",10,10,23)
NFI.% = 1
ROW.%(1)=10:COL.%(1)=24:LNG.%(1)=8:ICD.$(1)="A"
NFL.%(1)=0:NFR.%(1)=0:NFU.%(1)=0:NFD.%(1)=0:DFA.$(1)=""
GOSUB 60200
IF ESC% = 1 THEN RETURN
IF 0 <> INSTR(IR.$(1),".") THEN IR.$(1) = LEFT$(IR.$(1),INSTR(IR.$(1),".")-1)
DB.FX.NAME.$= IR.$(1)+".DBF"
CLS
CALL DB.OPEN(DB.FX.NAME.$,DB.FX.%,DB.FIELDS.%,DB.LAST.OPEN.$,DB.HDR.LEN.%, _
DB.HDR.REC.TOT.!,DB.LEN.%)
CALL DB.STRUC(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
FILL% = 1
FIELD #DB.FX.%,1 AS DB.DELETE.$,DB.LEN.%-1 AS DB.REC$
FOR I = 1 TO DB.FIELDS.%
IF I = 10 THEN EXIT FOR
FIELD #DB.FX.% , FILL% AS FILL$, DB.LENGTH.%(I) AS DB.FIELD.$(I)
FILL% = FILL% + DB.LENGTH.%(I)
NEXT I
RETURN

STRUCTURE:
GOSUB SCREENFILE
RETURN

QUIT:
IF DB.FIELDS.% <> 0 THEN _
CALL DB.CLOSE(DB.FX.%,DB.FX.NAME.$,DB.HDR.REC.TOT.!,DB.RC.%)
CLS
END


CREATEFILE:
CLS
MSG1$ = "Enter File Name Of New .DBF File."
MSG2$ = ""
MSG3$ = "Esc To Exit"
GOSUB DISP.MSG
CALL FASTPRT("FILE NAME ==>",10,10,17)
NFI.% = 1
ROW.%(1)=10:COL.%(1)=24:LNG.%(1)=8:ICD.$(1)="A"
NFL.%(1)=0:NFR.%(1)=0:NFU.%(1)=0:NFD.%(1)=0
GOSUB 60200
IF ESC% = 1 THEN RETURN
IF 0 <> INSTR(IR.$(1),".") THEN IR.$(1) = LEFT$(IR.$(1),INSTR(IR.$(1),".")-1)
DB.FX.NAME.$= IR.$(1)+".DBF"
CLS
DB.FIELDS.% = 10
GOSUB SCREENFILE
DB.FIELDS.% = 0
DB.FX.% = 1
FOR I = 1 TO 40 STEP 4
IF LEFT$(IR.$(I),1) < "A" THEN EXIT FOR
DB.FIELDS.% = DB.FIELDS.% + 1
DB.NAME.$(DB.FIELDS.%)=IR.$(I)

DB.LENGTH.%(DB.FIELDS.%)=VAL(IR.$(I+1))
DB.TYPE.$(DB.FIELDS.%)=IR.$(I+2)
DB.DEC.%(DB.FIELDS.%)=VAL(IR.$(I+3))
NEXT I
CALL DB.CREATE(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
CALL DB.OPEN(DB.FX.NAME.$,DB.FX.%,DB.FIELDS.%,DB.LAST.OPEN.$,DB.HDR.LEN.%, _
DB.HDR.REC.TOT.!,DB.LEN.%)
CALL DB.STRUC(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
FILL% = 1
FIELD #DB.FX.%,1 AS DB.DELETE.$,DB.LEN.%-1 AS DB.REC$
FOR I = 1 TO DB.FIELDS.%
IF I = 10 THEN EXIT FOR
FIELD #DB.FX.% , FILL% AS FILL$, DB.LENGTH.%(I) AS DB.FIELD.$(I)
FILL% = FILL% + DB.LENGTH.%(I)
NEXT I
RETURN


MENU:CALL BARMENU(MENULINE$+TIME$+" ", _
MENUFG%, _
MENUBG%, _
BLKSIZE%, _
BLKNUM%, _
MAXSIZE%(),_
MAXITEMS%(),_
ITEMS$(), _
MENUSLCT%,_
ITEMSLCT%)
RETURN
END
CALL DB.DEL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)

END
SCREENREC:
R.%=1:C.%=34:P.$="QB-DB3 DEMO":GOSUB 61000
LOCATE 6,16:PRINT "RECORD # ";:PRINT USING "###";DB.NUM.%;
IF DB.DELETE.$ = "*" THEN PRINT " DELETED" ELSE PRINT " "
ULR.%=5:ULC.%=14:WOB.%=16:HUB.%=3:GOSUB 59000
ULR.%=07:ULC.%=14:WOB.%=16:HUB.%=13:GOSUB 59000
NFI.%=10
'Data input control section
I1 = 09
FOR I = 1 TO DB.FIELDS.%
IF I > 10 THEN EXIT FOR
R.%=I1:C.%=16:P.$=DB.NAME.$(I):GOSUB 61000
ROW.%(I)=I1
COL.%(I)=33
LNG.%(I)=DB.LENGTH.%(I)
IF DB.TYPE.$(I) = "C" THEN
ICD.$(I)="A"
ELSE
ICD.$(I)=DB.TYPE.$(I)
IF DB.TYPE.$(I) = "N" THEN
DEC.%(I) = DB.DEC.%(I)
END IF
END IF
NFL.%(I)=I-1
NFR.%(I)=I
NFU.%(I)=I-1
NFD.%(I)=I+1
DFA.$(I)=DB.FIELD.$(I)
I1 = I1 + 1
NEXT I
NFD.%(I-1)=0
NFL.%(1)=0
NFU.%(1)=0
NFR.%(I-1)=0
NFI.%=I-1
GOSUB 60200
RETURN
SCREENFILE:
'Build Screen
R.%=1:C.%=34:P.$="QB-DB3 DEMO":GOSUB 61000
R.%=6:C.%=18:P.$="FIELD LENGTH TYPE DECIMAL":GOSUB 61000
ULR.%=5:ULC.%=14:WOB.%=16:HUB.%=3:GOSUB 59000
ULR.%=5:ULC.%=29:WOB.%=12:HUB.%=3:GOSUB 59000
ULR.%=5:ULC.%=40:WOB.%=11:HUB.%=3:GOSUB 59000
ULR.%=5:ULC.%=50:WOB.%=13:HUB.%=3:GOSUB 59000
ULR.%=07:ULC.%=14:WOB.%=16:HUB.%=13:GOSUB 59000
ULR.%=07:ULC.%=29:WOB.%=12:HUB.%=13:GOSUB 59000
ULR.%=07:ULC.%=40:WOB.%=11:HUB.%=13:GOSUB 59000
ULR.%=07:ULC.%=50:WOB.%=13:HUB.%=13:GOSUB 59000
'Data input control section
FOR I = 0 TO 36 STEP 4
ROW.%(I+1)=I1+09:COL.%(I+1)=16 :LNG.%(I+1)=10 :ICD.$(I+1)="A"
NFL.%(I+1)=I+00:NFR.%(I+1)=I+02:NFU.%(I+1)=I+00:NFD.%(I+1)=5:DFA.$(I+1)=DB.NAME.$((I/4)+1)
ROW.%(I+2)=I1+09:COL.%(I+2)=33 :LNG.%(I+2)=03 :ICD.$(I+2)="N"
NFL.%(I+2)=I+01:NFR.%(I+2)=I+03:NFU.%(I+2)=I+01:NFD.%(I+2)=5:DFA.$(I+2)=STR$(DB.LENGTH.%((I/4)+1))
ROW.%(I+3)=I1+09:COL.%(I+3)=44 :LNG.%(I+3)=01 :ICD.$(I+3)="1"' :ICA.$(I+3)="CND"
NFL.%(I+3)=I+02:NFR.%(I+3)=I+04:NFU.%(I+3)=I+01:NFD.%(I+3)=5:DFA.$(I+3)=DB.TYPE.$((I/4)+1)
ROW.%(I+4)=I1+09:COL.%(I+4)=54 :LNG.%(I+4)=02 :ICD.$(I+4)="N"
NFL.%(I+4)=I+03:NFR.%(I+4)=I+05:NFU.%(I+4)=I+01:NFD.%(I+4)=5:DFA.$(I+4)=STR$(DB.DEC.%((I/4)+1))
I1 = I1 + 1
NEXT I
NFI.% = DB.FIELDS.%*4
IF NFI.% > 40 THEN NFI.% = 40
NFL.%(1)=0
NFU.%(1)=0
FOR I = NFI.%-4 TO NFI.%
NFD.%(I)=0
NFR.%(I)=0
NEXT I
GOSUB 60200
RETURN
HELP:
CLS
R.%=2:C.%=30:P.$="QUICK BASIC - DBASEIII":GOSUB 61000
R.%=3:C.%=34:P.$="I/O INTERFACE":GOSUB 61000
LOCATE 5,1
PRINT "THIS DEMO PROGRAM WORKS JUST LIKE THE QB3 EDITOR WITHOUT A MOUSE,"
PRINT "SIMPLY PRESS DOWN THE ALT KEY PLUS THE FIRST CHARACTER OF THE DESIRED"
PRINT "ITEM WITHIN THE MENU. THEN USE YOUR CURSOR KEYS TO SELECT THE APPROPIATE"
PRINT "CHOICE WITHIN THE PANEL."
PRINT
PRINT "ALL THE ITEMS IN THE PANELS RESEMBLE THEIR DB3 COUNTER PARTS AND SHOULD"
PRINT "BE USED ACCORDINGLY."
PRINT
PRINT "SOME LIMITATIONS HAVE BEEN BUILT AROUND THE DEMO LIBRARY THESE ARE:
PRINT " 1) A MAXIMUM OF 50 RECORDS PER FILE ARE ALLOWED"
PRINT " 2) A MAXIMUM OF 10 FIELDS PER RECORD"
PRINT
PRINT "BY CREATING THESE LIMITATIONS IT WILL ENSURE ME THAT EVERY PERSON THAT"
PRINT "FINDS THIS LIBRARY USEFULL WILL IN FACT REGISTER. TO REGISTER USE THE"
PRINT "ORDER FORM IN QBDB3.DOC."
LOCATE 23,33:PRINT "Press Any Key";
A$=INPUT$(1)
CLS
ESC% = 0
GOTO SHOWMENU

59000 '
CALL BDTBOX(ULR.%,ULC.%,WOB.%,HUB.%)
RETURN
'
60200 '
CALL BDTSCREN (COL.%(),ROW.%(),LNG.%(),DEC.%(),NFI.%,NFD.%(),NFU.%(),_
NFL.%(),NFR.%(),ICD.$(),DFA.$(),IPC.$(),ICA.$(),_
LLA.$(),ULA.$(),IR.$(),USER.$(),BARCODE$,ESC%)
COLOR 7,1
RETURN
'
61000 'DISPLAY PROMPT P.$ AT R.% AND C.%
LOCATE R.%,C.%:PRINT P.$;:RETURN
'
CALL BDTFIELD (C.%,R.%,L.%,D.%,ITC.$,E.$,IP.$,ITS.$,LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
COLOR 7,1
RETURN
'
DISP.MSG:
CALL MAKEWIND(21,2,24,79,2,0,7,0,0,"")
CALL FASTPRT(MSG1$,21,5,112)
CALL FASTPRT(MSG2$,22,5,112)
CALL FASTPRT(MSG3$,23,5,112)
RETURN