home *** CD-ROM | disk | FTP | other *** search
/ DP Tool Club 12 / CD_ASCQ_12_0294.iso / maj / 421 / ez_creat.bas < prev    next >
BASIC Source File  |  1993-08-03  |  5KB  |  206 lines
  1. DECLARE FUNCTION EzCreateDXB% (Filename$, NoFields%, FieldInfo$())
  2.  
  3. DEFINT A-Z
  4.  
  5. REM $INCLUDE: 'BULLET.BI'
  6. 'ez_creat.bas 31-May-92 chh
  7. '--shows an easy method to create BULLET DBF data files using a FUNCTION
  8. 'C>bc ez_creat /o;
  9. 'C>link ez_creat,,nul,bullet;
  10.  
  11.                                
  12. DIM DFP AS DOSFilePack
  13. DIM MP AS MemoryPack
  14. DIM IP AS InitPack
  15. DIM EP AS ExitPack
  16. DIM CDP AS CreateDataPack
  17. DIM OP AS OpenPack
  18. DIM DP AS DescriptorPack
  19.  
  20. DIM NameDAT AS STRING * 80
  21. NameDAT = ".\EZ_TEST.DBF" + CHR$(0)
  22.  
  23. level = 100
  24. MP.Func = MemoryXB
  25. stat = BULLET(MP)
  26. IF MP.Memory < 140000 THEN
  27.     QBheap& = SETMEM(-150000)       'hog wild, 64K would do okay
  28.     MP.Func = MemoryXB
  29.     stat = BULLET(MP)
  30.     IF MP.Memory < 140000 THEN stat = 8: GOTO Abend
  31. END IF
  32.  
  33. level = 110
  34. IP.Func = InitXB
  35. IP.JFTmode = 0
  36. stat = BULLET(IP)
  37. IF stat THEN GOTO Abend
  38.  
  39. level = 120
  40. EP.Func = AtExitXB
  41. stat = BULLET(EP)
  42.  
  43. level = 130
  44. DFP.Func = DeleteFileDOS
  45. DFP.FilenamePtrOff = VARPTR(NameDAT)
  46. DFP.FilenamePtrSeg = VARSEG(NameDAT)
  47. stat = BULLET(DFP)
  48.  
  49. '-------------------------------------------------------------------------
  50. 'this is the simplified method to create BULLET data files
  51. 'simple in that you just use a string array with each element of the array
  52. 'set to the corresponding field info for the DBF data record
  53.  
  54. level = 1000
  55. NoFields = 4
  56. REDIM FieldInfo$(1 TO NoFields)
  57. FieldInfo$(1) = "LASTNAME,C,19,0"
  58. FieldInfo$(2) = "FIRSTNAME,C,15,0"
  59. FieldInfo$(3) = "BIRTHDATE,D,8,0"
  60. FieldInfo$(4) = "SALARY,N,10,2"
  61. stat = EzCreateDXB(NameDAT, NoFields, FieldInfo$())
  62. IF stat THEN GOTO Abend
  63.  
  64. 'just open it up and print out the field descriptors to the data file just
  65. 'created
  66.  
  67. level = 1010
  68. OP.Func = OpenDXB
  69. OP.FilenamePtrOff = VARPTR(NameDAT)
  70. OP.FilenamePtrSeg = VARSEG(NameDAT)
  71. OP.ASmode = ReadWrite + DenyNone
  72. stat = BULLET(OP)
  73. IF stat THEN GOTO Abend
  74. HandDAT = OP.Handle
  75.  
  76. level = 1020
  77. DP.Func = GetDescriptorXB
  78. DP.Handle = HandDAT
  79. PRINT
  80. PRINT "FieldName  T  L  D"
  81. PRINT "---------  - -- --"
  82. FOR i = 1 TO NoFields
  83.    DP.FieldNumber = i
  84.    stat = BULLET(DP)
  85.    IF stat = 0 THEN
  86.       PRINT DP.FD.FieldName; DP.FD.FieldType;
  87.       PRINT ASC(DP.FD.FieldLength); ASC(DP.FD.FieldDC)
  88.    ELSE
  89.       EXIT FOR
  90.    END IF
  91. NEXT
  92.  
  93. PRINT
  94. PRINT "Okay."
  95. EndIt:
  96. EP.Func = ExitXB
  97. stat = BULLET(EP)
  98. END
  99.  
  100.  
  101. Abend:
  102. PRINT
  103. PRINT "Error:"; stat; "at level"; level; "while performing ";
  104. SELECT CASE level
  105. CASE IS = 999
  106.    SELECT CASE level
  107.    CASE 100
  108.       PRINT "a memory request of 150K."
  109.    CASE 110
  110.       PRINT "BULLET initialization."
  111.    CASE 120
  112.       PRINT "registering of ExitXB with _atexit."
  113.    CASE ELSE
  114.       PRINT "Preliminaries unknown."
  115.    END SELECT
  116. CASE IS <= 1099
  117.    SELECT CASE level
  118.    CASE 1000
  119.       PRINT "data file create."
  120.    CASE 1010
  121.       PRINT "data file open."
  122.    CASE 1020
  123.       PRINT "data get descriptors."
  124.    CASE ELSE
  125.       PRINT "data file unknown."
  126.    END SELECT
  127. CASE ELSE
  128.    PRINT "unknown."
  129. END SELECT
  130. GOTO EndIt
  131.  
  132. FUNCTION EzCreateDXB (Filename$, NoFields, FieldInfo$())
  133.  
  134. 'example of using modular programming to customize the BULLET API
  135. 'FieldInfo$() is a var-len string array with each element made up as:
  136. ' FieldInfo$(i) = "FIELDNAME,FIELDTYPE,FIELDLEN,FIELDDC" as in:
  137. ' FieldInfo$(1) = "LASTNAME,C,19,0"
  138. ' FieldInfo$(2) = "FIRSTNAME,C,15,0"
  139. ' FieldInfo$(3) = "BIRTHDATE,D,8,0"
  140. ' FieldInfo$(4) = "SALARY,N,10,2"
  141. '   and so on
  142.  
  143. REDIM FieldList(1 TO NoFields) AS FieldDescTYPE
  144.  
  145. DIM CDP AS CreateDataPack
  146. DIM TmpName AS STRING * 80
  147. DIM TmpStr AS STRING * 32
  148.  
  149. FOR i = 1 TO NoFields
  150.    GOSUB ParseInfo
  151.    IF stat THEN EXIT FOR
  152.    FieldList(i).FieldName = fldname$
  153.    FieldList(i).FieldType = fldtype$
  154.    FieldList(i).FieldLength = CHR$(fldlength)
  155.    FieldList(i).FieldDC = CHR$(flddc)
  156. NEXT
  157.  
  158. IF stat = 0 THEN
  159.    TmpName = Filename$ + CHR$(0)
  160.    CDP.Func = CreateDXB
  161.    CDP.FilenamePtrOff = VARPTR(TmpName)
  162.    CDP.FilenamePtrSeg = VARSEG(TmpName)
  163.    CDP.NoFields = NoFields
  164.    CDP.FieldListPtrOff = VARPTR(FieldList(1))
  165.    CDP.FieldListPtrSeg = VARSEG(FieldList(1))
  166.    CDP.FileID = 3
  167.    stat = BULLET(CDP)
  168. END IF
  169.  
  170. EzCreateDXB = stat
  171. EXIT FUNCTION
  172.  
  173. '--------
  174. ParseInfo:
  175. stat = 0
  176. cptr = 1
  177. nptr = 0
  178. TmpStr = LTRIM$(RTRIM$(FieldInfo$(i))) + CHR$(0)
  179. nptr = INSTR(cptr, TmpStr, ",")
  180. IF nptr > cptr THEN
  181.    fldname$ = LTRIM$(RTRIM$(MID$(TmpStr, cptr, nptr - cptr))) + STRING$(11, 0)
  182.    cptr = nptr + 1
  183.    nptr = INSTR(cptr, TmpStr, ",")
  184.    IF nptr > cptr THEN
  185.       fldtype$ = LTRIM$(RTRIM$(MID$(TmpStr, cptr, nptr - cptr)))
  186.       cptr = nptr + 1
  187.       nptr = INSTR(cptr, TmpStr, ",")
  188.       IF nptr > cptr THEN
  189.          fldlength = VAL(MID$(TmpStr, cptr, nptr - cptr))
  190.          cptr = nptr + 1
  191.          nptr = INSTR(cptr, TmpStr, CHR$(0))
  192.          IF nptr > cptr THEN
  193.             flddc = VAL(MID$(TmpStr, cptr, nptr - cptr))
  194.          END IF
  195.       END IF
  196.    END IF
  197. END IF
  198. IF nptr <= cptr THEN stat = 243  '(for lack of a better error code...)
  199.  
  200. 'may want to verify that fldname$,fldtype$,fldlength,flddc are within limits
  201.  
  202. RETURN
  203.  
  204. END FUNCTION
  205.  
  206.