home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / GLEN / QBDB3.ZIP / DB3DEMO.BAS next >
BASIC Source File  |  1987-10-16  |  12KB  |  402 lines
  1.       KEY OFF
  2.        CLS
  3.       DIM COL.%(40),ROW.%(40),LNG.%(40),DEC.%(40)
  4.       DIM NFD.%(40),NFL.%(40),NFR.%(40),NFU.%(40)
  5.       DIM DFA.$(40),LLA.$(40),ULA.$(40),IR.$(40)
  6.       DIM ICA.$(40),ICD.$(40),IPC.$(40),USER.$(40)
  7.       USER.$(1) = "CND"
  8.       LOCATE 12,20
  9.       PRINT "ARE YOU USING COLOR OR MONOCROME ?"
  10.       CALL BDTFIELD (54,12,1,0,"C",E.$,IP.$,"MC",LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
  11.       IF R.$ = "C" THEN
  12.      MENUFG%=0
  13.      MENUBG%=3
  14.       ELSE
  15.      MENUFG%=7
  16.      MENUBG%=9
  17.       END IF
  18.       DB.FX.% = 1
  19.       BARCODE$ = CHR$(35)+CHR$(33)+CHR$(19)
  20.       ESC% = 0
  21.       REM $DYNAMIC
  22.       DIM DB.NAME.$(50),DB.LENGTH.%(50),DB.TYPE.$(50),DB.DEC.%(50),DB.FIELD.$(50)
  23.       REM $STATIC
  24.       CLS
  25.  
  26. REM MENU FIELDS
  27. MENULINE$="   HELP      FILES     RECORDS   "
  28. MENULINE$=MENULINE$+SPACE$(70-LEN(MENULINE$))
  29.  
  30. BLKSIZE%=10
  31. BLKNUM%=3
  32. DIM ITEMS$(3,9)
  33. ITEMS$(1,1)="HELP"
  34. MAXSIZE%(1)=4:MAXITEMS%(1)=2
  35. ITEMS$(2,1)="USE     ":ITEMS$(2,2)="CREATE  "
  36. ITEMS$(2,3)="STRUCTURE":ITEMS$(2,4)="QUIT   "
  37. MAXSIZE%(2)=9:MAXITEMS%(2)=4
  38. ITEMS$(3,1)="APPEND  ":ITEMS$(3,2)="EDIT    ":ITEMS$(3,3)="BROWSE   "
  39. ITEMS$(3,4)="DELETE  ":ITEMS$(3,5)="RECALL  "::ITEMS$(3,6)="PACK    "
  40. MAXSIZE%(3)=8:MAXITEMS%(3)=6
  41.  
  42. MENUSLCT%=0
  43. ITEMSLCT%=0
  44. GOTO HELP
  45.  
  46. TRUE = -1
  47. FALSE = 0
  48. WHILE 1 = 1
  49.     MENULINE$=LEFT$(MENULINE$,70)
  50.     CALL FASTPRT(MENULINE$+TIME$+"  ",1,1,48)
  51.     CALL BDTFIELD (79,1,1,D.%,ITC.$,E.$,IP.$,ITS.$,LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
  52. SHOWMENU:
  53.     COLOR 7,1
  54.     MENUSLCT% = ESC% - 100
  55.     IF MENUSLCT% = 1 THEN GOTO HELP
  56.     IF MENUSLCT% > 0 THEN
  57.        CALL FASTPRT(MENULINE$+TIME$,1,1,113)
  58.        GOSUB MENU
  59.        GROW = 1
  60.     END IF
  61.     IF MENUSLCT% = 2 THEN  ON ITEMSLCT% GOSUB OPENFILE,_
  62.                           CREATEFILE,_
  63.                           STRUCTURE,_
  64.                           QUIT
  65.     IF MENUSLCT% = 3 THEN  ON ITEMSLCT% GOSUB ADD,_
  66.                           EDITREC,_
  67.                           RETRIEVE,_
  68.                           RECORD.DELETE,_
  69.                           RECORD.RECALL,_
  70.                           PACK
  71.     CLS
  72. WEND
  73.  
  74. ADD:
  75.     CLS
  76.     MSG1$ = CHR$(24)+" Prior Field "+CHR$(25)+" Next Field"
  77.     MSG2$ = ""
  78.     MSG3$ = "Esc To Exit"
  79.     GOSUB DISP.MSG
  80.     COLOR 7,1
  81.     DB.NUM.% = DB.NUM.% + 1
  82.  
  83.     GOSUB SCREENREC
  84.     FOR I = 1 TO DB.FIELDS.%
  85.     IF ICD.$(I) = "N" THEN
  86.        DB3.NUM.# = VAL(IR.$(I))
  87.        CALL DB3.NUM.STR(DB3.NUM.#,DB.DEC.%(I),DB.STR.NUM$)
  88.        RSET DB.FIELD.$(I) = IR.$(I)
  89.     ELSE
  90.        LSET DB.FIELD.$(I) = IR.$(I)
  91.     END IF
  92.  
  93.     NEXT I
  94.  
  95.     CALL DB.ADD(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  96. RETURN
  97.  
  98. EDITREC:
  99.     CLS
  100.     MSG1$ = CHR$(24)+"      Prior Field     "+CHR$(25)+"      Next Field"
  101.     MSG2$ = "PgUp   Prior Record    PgDn   Next Record"
  102.     MSG3$ = "Esc To Exit"
  103.     GOSUB DISP.MSG
  104.     COLOR 7,0
  105.     UPDATE = TRUE
  106.     GOSUB RETRIEVE
  107.     UPDATE = FALSE
  108. RETURN
  109.  
  110. RETRIEVE:
  111.     IF ITEMSLCT% = 3 THEN
  112.        CLS
  113.        MSG1$ = "PgUp   Prior Record    PgDn   Next Record"
  114.        MSG2$ = ""
  115.        MSG3$ = "Esc To Exit"
  116.        GOSUB DISP.MSG
  117.     END IF
  118. DB.NUM.% = 1
  119. CALL DB.GET(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  120. GOSUB SCREENREC
  121. WHILE ESC% <> 1
  122.     IF DEL THEN
  123.        IF ESC% = 105 THEN _
  124.       CALL DB.DEL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  125.     END IF
  126.     IF RECALL THEN
  127.        IF ESC% = 103 THEN _
  128.       CALL DB.RECALL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  129.     END IF
  130.     IF UPDATE THEN
  131.        FOR I = 1 TO 10
  132.        IF IR.$(I) <> "" THEN
  133.           PUTREC = TRUE
  134.           LSET DB.FIELD.$(I) = IR.$(I)
  135.        END IF
  136.        NEXT I
  137.        IF PUTREC THEN _
  138.       CALL DB.PUT(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  139.     END IF
  140.     IF ESC% = 9 THEN
  141.        DB.NUM.% = DB.NUM.% - 1
  142.        IF DB.NUM.% < 1 THEN DB.NUM.% = 1
  143.     END IF
  144.     IF ESC% = 3 THEN
  145.        DB.NUM.% = DB.NUM.% + 1
  146.        IF DB.NUM.% >  DB.HDR.REC.TOT.! THEN DB.NUM.% = DB.HDR.REC.TOT.!
  147.     END IF
  148.     PUTREC = FALSE
  149.     CALL DB.GET(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  150.     GOSUB SCREENREC
  151. WEND
  152. RETURN
  153.  
  154. RECORD.DELETE:
  155.     CLS
  156.     MSG1$ = "Alt+D To mark Record For Deletion"
  157.     MSG2$ = ""
  158.     MSG3$ = "Esc To Exit"
  159.     GOSUB DISP.MSG
  160.     DEL = TRUE
  161.     GOSUB RETRIEVE
  162.     DEL = FALSE
  163. RETURN
  164.  
  165. PACK:
  166. CALL DB.PACK(DB.FX.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  167. RETURN
  168.  
  169. RECORD.RECALL:
  170.     CLS
  171.     MSG1$ = "Alt+R To Recall Record"
  172.     MSG2$ = ""
  173.     MSG3$ = "Esc To Exit"
  174.     GOSUB DISP.MSG
  175.     RECALL = TRUE
  176.     GOSUB RETRIEVE
  177.     RECALL = FALSE
  178.     MSG$ = "Esc To Exit"
  179. RETURN
  180.  
  181. OPENFILE:
  182.     CLS
  183.     MSG1$ = "Enter File Name Of Existing .DBF File"
  184.     MSG2$ = ""
  185.     MSG3$ = "Esc To Exit"
  186.     GOSUB DISP.MSG
  187.     DB.FX.% = 1
  188.     CALL FASTPRT("FILE NAME ==>",10,10,23)
  189.     NFI.% = 1
  190.     ROW.%(1)=10:COL.%(1)=24:LNG.%(1)=8:ICD.$(1)="A"
  191.     NFL.%(1)=0:NFR.%(1)=0:NFU.%(1)=0:NFD.%(1)=0:DFA.$(1)=""
  192.     GOSUB 60200
  193.     IF ESC% = 1 THEN RETURN
  194.     IF 0 <> INSTR(IR.$(1),".") THEN IR.$(1) = LEFT$(IR.$(1),INSTR(IR.$(1),".")-1)
  195.     DB.FX.NAME.$= IR.$(1)+".DBF"
  196.     CLS
  197.     CALL DB.OPEN(DB.FX.NAME.$,DB.FX.%,DB.FIELDS.%,DB.LAST.OPEN.$,DB.HDR.LEN.%,   _
  198.          DB.HDR.REC.TOT.!,DB.LEN.%)
  199.     CALL DB.STRUC(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
  200.          DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
  201.     FILL% = 1
  202.     FIELD #DB.FX.%,1 AS DB.DELETE.$,DB.LEN.%-1 AS DB.REC$
  203.     FOR I = 1 TO DB.FIELDS.%
  204.         IF I = 10 THEN EXIT FOR
  205.         FIELD #DB.FX.% , FILL% AS FILL$, DB.LENGTH.%(I) AS DB.FIELD.$(I)
  206.         FILL% = FILL% + DB.LENGTH.%(I)
  207.     NEXT I
  208. RETURN
  209.  
  210. STRUCTURE:
  211.     GOSUB SCREENFILE
  212. RETURN
  213.  
  214. QUIT:
  215.     IF DB.FIELDS.% <> 0 THEN _
  216.        CALL DB.CLOSE(DB.FX.%,DB.FX.NAME.$,DB.HDR.REC.TOT.!,DB.RC.%)
  217.     CLS
  218.     END
  219.  
  220.  
  221. CREATEFILE:
  222.     CLS
  223.     MSG1$ = "Enter File Name Of New .DBF File."
  224.     MSG2$ = ""
  225.     MSG3$ = "Esc To Exit"
  226.     GOSUB DISP.MSG
  227.     CALL FASTPRT("FILE NAME ==>",10,10,17)
  228.     NFI.% = 1
  229.     ROW.%(1)=10:COL.%(1)=24:LNG.%(1)=8:ICD.$(1)="A"
  230.     NFL.%(1)=0:NFR.%(1)=0:NFU.%(1)=0:NFD.%(1)=0
  231.     GOSUB 60200
  232.     IF ESC% = 1 THEN RETURN
  233.     IF 0 <> INSTR(IR.$(1),".") THEN IR.$(1) = LEFT$(IR.$(1),INSTR(IR.$(1),".")-1)
  234.     DB.FX.NAME.$= IR.$(1)+".DBF"
  235.     CLS
  236.     DB.FIELDS.% = 10
  237.     GOSUB SCREENFILE
  238.     DB.FIELDS.% = 0
  239.     DB.FX.% = 1
  240.     FOR I = 1 TO 40 STEP 4
  241.         IF LEFT$(IR.$(I),1) < "A" THEN EXIT FOR
  242.         DB.FIELDS.% = DB.FIELDS.% + 1
  243.         DB.NAME.$(DB.FIELDS.%)=IR.$(I)
  244.         DB.LENGTH.%(DB.FIELDS.%)=VAL(IR.$(I+1))
  245.         DB.TYPE.$(DB.FIELDS.%)=IR.$(I+2)
  246.         DB.DEC.%(DB.FIELDS.%)=VAL(IR.$(I+3))
  247.     NEXT I
  248.     CALL DB.CREATE(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
  249.          DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
  250.     CALL DB.OPEN(DB.FX.NAME.$,DB.FX.%,DB.FIELDS.%,DB.LAST.OPEN.$,DB.HDR.LEN.%,   _
  251.          DB.HDR.REC.TOT.!,DB.LEN.%)
  252.     CALL DB.STRUC(DB.FX.%,DB.FX.NAME.$,DB.NAME.$(),DB.LENGTH.%(),_
  253.          DB.TYPE.$(),DB.DEC.%(),DB.FIELDS.%,DB.LEN.%,DB.RC.%)
  254.     FILL% = 1
  255.     FIELD #DB.FX.%,1 AS DB.DELETE.$,DB.LEN.%-1 AS DB.REC$
  256.     FOR I = 1 TO DB.FIELDS.%
  257.         IF I = 10 THEN EXIT FOR
  258.         FIELD #DB.FX.% , FILL% AS FILL$, DB.LENGTH.%(I) AS DB.FIELD.$(I)
  259.         FILL% = FILL% + DB.LENGTH.%(I)
  260.     NEXT I
  261. RETURN
  262.  
  263.  
  264. MENU:CALL BARMENU(MENULINE$+TIME$+"  ",  _
  265.         MENUFG%,    _
  266.         MENUBG%,    _
  267.         BLKSIZE%,   _
  268.         BLKNUM%,    _
  269.         MAXSIZE%(),_
  270.         MAXITEMS%(),_
  271.         ITEMS$(),  _
  272.         MENUSLCT%,_
  273.         ITEMSLCT%)
  274. RETURN
  275. END
  276. CALL DB.DEL(DB.FX.%,DB.NUM.%,DB.LEN.%,DB.HDR.LEN.%,DB.HDR.REC.TOT.!)
  277.  
  278. END
  279. SCREENREC:
  280.       R.%=1:C.%=34:P.$="QB-DB3 DEMO":GOSUB 61000
  281.       LOCATE 6,16:PRINT "RECORD # ";:PRINT USING "###";DB.NUM.%;
  282.       IF DB.DELETE.$ = "*" THEN PRINT " DELETED" ELSE PRINT "        "
  283.       ULR.%=5:ULC.%=14:WOB.%=16:HUB.%=3:GOSUB 59000
  284.       ULR.%=07:ULC.%=14:WOB.%=16:HUB.%=13:GOSUB 59000
  285.  NFI.%=10
  286.  'Data input control section
  287.   I1 = 09
  288.   FOR I = 1 TO DB.FIELDS.%
  289.       IF I > 10 THEN EXIT FOR
  290.       R.%=I1:C.%=16:P.$=DB.NAME.$(I):GOSUB 61000
  291.       ROW.%(I)=I1
  292.       COL.%(I)=33
  293.       LNG.%(I)=DB.LENGTH.%(I)
  294.       IF DB.TYPE.$(I) = "C" THEN
  295.      ICD.$(I)="A"
  296.       ELSE
  297.      ICD.$(I)=DB.TYPE.$(I)
  298.      IF DB.TYPE.$(I) = "N" THEN
  299.         DEC.%(I) = DB.DEC.%(I)
  300.      END IF
  301.       END IF
  302.       NFL.%(I)=I-1
  303.       NFR.%(I)=I
  304.       NFU.%(I)=I-1
  305.       NFD.%(I)=I+1
  306.       DFA.$(I)=DB.FIELD.$(I)
  307.       I1 = I1 + 1
  308.   NEXT I
  309.   NFD.%(I-1)=0
  310.   NFL.%(1)=0
  311.   NFU.%(1)=0
  312.   NFR.%(I-1)=0
  313.   NFI.%=I-1
  314.   GOSUB 60200
  315. RETURN
  316. SCREENFILE:
  317.       'Build Screen
  318.       R.%=1:C.%=34:P.$="QB-DB3 DEMO":GOSUB 61000
  319.       R.%=6:C.%=18:P.$="FIELD         LENGTH     TYPE      DECIMAL":GOSUB 61000
  320.       ULR.%=5:ULC.%=14:WOB.%=16:HUB.%=3:GOSUB 59000
  321.       ULR.%=5:ULC.%=29:WOB.%=12:HUB.%=3:GOSUB 59000
  322.       ULR.%=5:ULC.%=40:WOB.%=11:HUB.%=3:GOSUB 59000
  323.       ULR.%=5:ULC.%=50:WOB.%=13:HUB.%=3:GOSUB 59000
  324.       ULR.%=07:ULC.%=14:WOB.%=16:HUB.%=13:GOSUB 59000
  325.       ULR.%=07:ULC.%=29:WOB.%=12:HUB.%=13:GOSUB 59000
  326.       ULR.%=07:ULC.%=40:WOB.%=11:HUB.%=13:GOSUB 59000
  327.       ULR.%=07:ULC.%=50:WOB.%=13:HUB.%=13:GOSUB 59000
  328.       'Data input control section
  329.       FOR I = 0 TO 36 STEP 4
  330.       ROW.%(I+1)=I1+09:COL.%(I+1)=16  :LNG.%(I+1)=10  :ICD.$(I+1)="A"
  331.       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)
  332.       ROW.%(I+2)=I1+09:COL.%(I+2)=33  :LNG.%(I+2)=03  :ICD.$(I+2)="N"
  333.       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))
  334.       ROW.%(I+3)=I1+09:COL.%(I+3)=44  :LNG.%(I+3)=01  :ICD.$(I+3)="1"'   :ICA.$(I+3)="CND"
  335.       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)
  336.       ROW.%(I+4)=I1+09:COL.%(I+4)=54  :LNG.%(I+4)=02  :ICD.$(I+4)="N"
  337.       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))
  338.       I1 = I1 + 1
  339.       NEXT I
  340.       NFI.% = DB.FIELDS.%*4
  341.       IF NFI.% > 40 THEN NFI.% = 40
  342.       NFL.%(1)=0
  343.       NFU.%(1)=0
  344.       FOR I = NFI.%-4 TO NFI.%
  345.       NFD.%(I)=0
  346.       NFR.%(I)=0
  347.       NEXT I
  348.       GOSUB 60200
  349. RETURN
  350. HELP:
  351.     CLS
  352.     R.%=2:C.%=30:P.$="QUICK BASIC - DBASEIII":GOSUB 61000
  353.     R.%=3:C.%=34:P.$="I/O INTERFACE":GOSUB 61000
  354.     LOCATE 5,1
  355.     PRINT "THIS DEMO PROGRAM WORKS JUST LIKE THE QB3 EDITOR WITHOUT A MOUSE,"
  356.     PRINT "SIMPLY PRESS DOWN THE ALT KEY PLUS THE FIRST CHARACTER OF THE DESIRED"
  357.     PRINT "ITEM WITHIN THE MENU. THEN USE YOUR CURSOR KEYS TO SELECT THE APPROPIATE"
  358.     PRINT "CHOICE WITHIN THE PANEL."
  359.     PRINT
  360.     PRINT "ALL THE ITEMS IN THE PANELS RESEMBLE THEIR DB3 COUNTER PARTS AND SHOULD"
  361.     PRINT "BE USED ACCORDINGLY."
  362.     PRINT
  363.     PRINT "SOME LIMITATIONS HAVE BEEN BUILT AROUND THE DEMO LIBRARY THESE ARE:
  364.     PRINT "     1)  A MAXIMUM OF 50 RECORDS PER FILE ARE ALLOWED"
  365.     PRINT "     2)  A MAXIMUM OF 10 FIELDS PER RECORD"
  366.     PRINT
  367.     PRINT "BY CREATING THESE LIMITATIONS IT WILL ENSURE ME THAT EVERY PERSON THAT"
  368.     PRINT "FINDS THIS LIBRARY USEFULL WILL IN FACT REGISTER. TO REGISTER USE THE"
  369.     PRINT "ORDER FORM IN QBDB3.DOC."
  370.     LOCATE 23,33:PRINT "Press Any Key";
  371.     A$=INPUT$(1)
  372.     CLS
  373. ESC% = 0
  374. GOTO SHOWMENU
  375.  
  376. 59000 '
  377.       CALL BDTBOX(ULR.%,ULC.%,WOB.%,HUB.%)
  378.       RETURN
  379.       '
  380. 60200 '
  381.       CALL BDTSCREN (COL.%(),ROW.%(),LNG.%(),DEC.%(),NFI.%,NFD.%(),NFU.%(),_
  382.              NFL.%(),NFR.%(),ICD.$(),DFA.$(),IPC.$(),ICA.$(),_
  383.              LLA.$(),ULA.$(),IR.$(),USER.$(),BARCODE$,ESC%)
  384.       COLOR 7,1
  385.       RETURN
  386.       '
  387. 61000 'DISPLAY PROMPT P.$ AT R.% AND C.%
  388.       LOCATE R.%,C.%:PRINT P.$;:RETURN
  389.       '
  390.       CALL BDTFIELD (C.%,R.%,L.%,D.%,ITC.$,E.$,IP.$,ITS.$,LL.$,UL.$,MSG%,R.$,USER.$(),MASK.$,BARCODE$,ESC%)
  391.       COLOR 7,1
  392.       RETURN
  393.       '
  394. DISP.MSG:
  395.     CALL MAKEWIND(21,2,24,79,2,0,7,0,0,"")
  396.     CALL FASTPRT(MSG1$,21,5,112)
  397.     CALL FASTPRT(MSG2$,22,5,112)
  398.     CALL FASTPRT(MSG3$,23,5,112)
  399.     RETURN
  400.  
  401.  
  402.