home *** CD-ROM | disk | FTP | other *** search
/ World of Shareware - Software Farm 2 / wosw_2.zip / wosw_2 / QBAS / IMB9007.ZIP / CREATEDB.BAS next >
BASIC Source File  |  1990-06-28  |  4KB  |  192 lines
  1. DECLARE FUNCTION DbfCreate% (FileIn$)
  2. DECLARE SUB DoDosCall (FileName$)
  3. DECLARE FUNCTION Exist% (FileName$)
  4.  
  5. DEFINT A-Z
  6.  
  7. 'PROGRAM - MAKEDBF.BAS
  8. 'Create a dBASE DBF file with each type of data
  9. 'field.
  10.  
  11. '  QB 4.5 users should use the QB.BI file in the
  12. '  next instruction
  13.  
  14. '$INCLUDE: 'QBX.BI'
  15.  
  16. ' Version 7.0 users MUST use RegTypeX instead of
  17. ' RegType because of far strings.  Note that error
  18. ' trapping code is not included. In your programs,
  19. ' you may want to handle error trapping in the
  20. ' event of "critical" errors.
  21.  
  22. DIM SHARED InRegs AS RegTypeX, OutRegs AS RegTypeX
  23.  
  24. TYPE DbfFieldMask
  25.     FdName    AS STRING * 11
  26.     FdType    AS STRING * 1
  27.     Reserved1 AS STRING * 4
  28.     FdLength  AS STRING * 1
  29.     FdDec     AS STRING * 1
  30.     Reserved2 AS STRING * 14
  31. END TYPE
  32.  
  33. TYPE DbfHdrMask
  34.     VersionNumber AS STRING * 1
  35.     Update        AS STRING * 3
  36.     NbrRec        AS LONG
  37.     HdrLen        AS INTEGER
  38.     RecLen        AS INTEGER
  39.     Reserved      AS STRING * 20
  40. END TYPE
  41.  
  42.     CLS
  43.  
  44.     FileName$ = "PLANETS.LAY"
  45.  
  46.     ActionCreate = DbfCreate(FileName$)
  47.  
  48.     PRINT "DBF file creation for "; FileName$;
  49.     IF ActionCreate THEN
  50.         PRINT " successful."
  51.     ELSE
  52.         PRINT " failed."
  53.     END IF
  54.  
  55.     END
  56.  
  57. FUNCTION DbfCreate% (FileIn$)
  58.  
  59.     PeriodPos = INSTR(FileIn$, ".")
  60.  
  61.     IF PeriodPos = 0 THEN
  62.         FileOut$ = FileIn$ + ".DBF"
  63.         FileIn$ = FileIn$ + ".LAY"
  64.     ELSE
  65.         FileOut$ = LEFT$(FileIn$, PeriodPos - 1) + _
  66.                    ".DBF"
  67.     END IF
  68.  
  69.     IF NOT Exist%(FileIn$) THEN
  70.         PRINT "Error - Layout file "; FileIn$; _
  71.               " does not exist."
  72.         EXIT FUNCTION
  73.     END IF
  74.     
  75.     IF Exist%(FileOut$) THEN
  76.         PRINT "Warning - DBF file "; FileOut$; _
  77.               " already exists."
  78.         PRINT "Replace current "; FileOut$; _
  79.               " (Y/N)?: ";
  80.         INPUT Response$
  81.         IF UCASE$(Response$) <> "Y" THEN
  82.             PRINT "File Not Replaced"
  83.             EXIT FUNCTION
  84.         END IF
  85.     END IF
  86.  
  87.     FileLayout = 1
  88.     NewDbfFile = 2
  89.  
  90.     OPEN FileIn$ FOR INPUT AS FileLayout
  91.     OPEN FileOut$ FOR BINARY AS NewDbfFile
  92.  
  93.     DIM FieldRec AS DbfFieldMask
  94.     DIM Header AS DbfHdrMask
  95.     
  96.     FieldCounter = 0
  97.     RecordLength = 0
  98.  
  99.     DbfCreate% = 0  'Set function to failed status
  100.  
  101.     EOH = &HD
  102.     EODbf = &H1A
  103.     
  104.     FieldRec.Reserved1 = STRING$(4, 0)
  105.     FieldRec.Reserved2 = STRING$(14, 0)
  106.  
  107.     'Position DBF file for first write
  108.  
  109.     SEEK NewDbfFile, 33
  110.  
  111.     'First process the fields
  112.  
  113.     WHILE NOT EOF(FileLayout)
  114.         LINE INPUT #FileLayout, Temp$
  115.         FieldCounter = FieldCounter + 1
  116.         Location = INSTR(Temp$, " ")
  117.         IF Location < 11 THEN
  118.             FdName$ = LEFT$(Temp$, Location - 1)
  119.         ELSE
  120.             FdName$ = LEFT$(Temp$, 10)
  121.         END IF
  122.         FieldRec.FdName = FdName$ + _
  123.                     STRING$(11 - LEN(FdName$), 0)
  124.         FieldRec.FdType = MID$(Temp$, 11, 1)
  125.         FieldRec.FdLength = _
  126.                      CHR$(VAL(MID$(Temp$, 12, 3)))
  127.         FieldRec.FdDec = _
  128.                       CHR$(VAL(MID$(Temp$, 15, 2)))
  129.         PUT NewDbfFile, , FieldRec
  130.         RecordLength = RecordLength + _
  131.                              ASC(FieldRec.FdLength)
  132.     WEND
  133.  
  134.     CLOSE FileLayout
  135.  
  136.     PUT NewDbfFile, , EOH  'End of header
  137.     PUT NewDbfFile, , EODbf'End of file
  138.  
  139. '  Now set the header information
  140.  
  141.     Header.VersionNumber = CHR$(&H3)
  142.     MID$(Header.Update, 1, 1) = _
  143.                 CHR$(VAL(RIGHT$(DATE$, 4)) - 1900)
  144.     MID$(Header.Update, 2, 1) = _
  145.                         CHR$(VAL(LEFT$(DATE$, 2)))
  146.     MID$(Header.Update, 3, 1) = _
  147.                       CHR$(VAL(MID$(DATE$, 4, 2)))
  148.     Header.NbrRec = 0
  149.     Header.HdrLen = FieldCounter * 32 + 33
  150.     Header.RecLen = RecordLength + 1
  151.     Header.Reserved = STRING$(20, 0)
  152.  
  153.     PUT NewDbfFile, 1, Header 'At beginning of file
  154.     CLOSE NewDbfFile
  155.     DbfCreate = -1       'Successful creation
  156. END FUNCTION
  157.  
  158. SUB DoDosCall (FileName$)
  159.  
  160. ' If you have QuickBASIC, change all
  161. ' occurrences of SSEG to VARSEG.
  162.  
  163. ' DOS requires an ASCIIZ string so add CHR$(0)
  164.  
  165.      Spec$ = FileName$ + CHR$(0)
  166.      InRegs.ds = SSEG(Spec$) ' Load DS:DX with
  167.      InRegs.dx = SADD(Spec$) ' address of Spec$
  168.      CALL InterruptX(&H21, InRegs, OutRegs)
  169.  
  170. END SUB
  171.  
  172. FUNCTION Exist% (FileName$)
  173.  
  174. ' See if a given file exists using
  175. ' DOS "Search for first match" service &H4E
  176.  
  177.      InRegs.ax = &H4E00
  178.      InRegs.cx = 63  ' Search for all files
  179.      DoDosCall (FileName$)
  180.  
  181. ' If AX contains a value, then file does not exist
  182.  
  183.      SELECT CASE OutRegs.ax
  184.          CASE 0
  185.              Exist% = -1
  186.          CASE ELSE
  187.              Exist% = 0
  188.      END SELECT
  189.  
  190. END FUNCTION
  191.  
  192.