DECLARE FUNCTION DbfCreate% (FileIn$)
DECLARE SUB DoDosCall (FileName$)
DECLARE FUNCTION Exist% (FileName$)

DEFINT A-Z

'PROGRAM - MAKEDBF.BAS
'Create a dBASE DBF file with each type of data
'field.

'  QB 4.5 users should use the QB.BI file in the
'  next instruction

'$INCLUDE: 'QBX.BI'

' Version 7.0 users MUST use RegTypeX instead of
' RegType because of far strings.  Note that error
' trapping code is not included. In your programs,
' you may want to handle error trapping in the
' event of "critical" errors.

DIM SHARED InRegs AS RegTypeX, OutRegs AS RegTypeX

TYPE DbfFieldMask
	FdName    AS STRING * 11
	FdType    AS STRING * 1
	Reserved1 AS STRING * 4
	FdLength  AS STRING * 1
	FdDec     AS STRING * 1
	Reserved2 AS STRING * 14
END TYPE

TYPE DbfHdrMask
	VersionNumber AS STRING * 1
	Update        AS STRING * 3
	NbrRec        AS LONG
	HdrLen        AS INTEGER
	RecLen        AS INTEGER
	Reserved      AS STRING * 20
END TYPE

	CLS

	FileName$ = "PLANETS.LAY"

	ActionCreate = DbfCreate(FileName$)

	PRINT "DBF file creation for "; FileName$;
	IF ActionCreate THEN
		PRINT " successful."
	ELSE
		PRINT " failed."
	END IF

	END

FUNCTION DbfCreate% (FileIn$)

	PeriodPos = INSTR(FileIn$, ".")

	IF PeriodPos = 0 THEN
		FileOut$ = FileIn$ + ".DBF"
		FileIn$ = FileIn$ + ".LAY"
	ELSE
		FileOut$ = LEFT$(FileIn$, PeriodPos - 1) + _
		           ".DBF"
	END IF

	IF NOT Exist%(FileIn$) THEN
		PRINT "Error - Layout file "; FileIn$; _
		      " does not exist."
		EXIT FUNCTION
	END IF
	
	IF Exist%(FileOut$) THEN
		PRINT "Warning - DBF file "; FileOut$; _
		      " already exists."
		PRINT "Replace current "; FileOut$; _
		      " (Y/N)?: ";
		INPUT Response$
		IF UCASE$(Response$) <> "Y" THEN
			PRINT "File Not Replaced"
			EXIT FUNCTION
		END IF
	END IF

	FileLayout = 1
	NewDbfFile = 2

	OPEN FileIn$ FOR INPUT AS FileLayout
	OPEN FileOut$ FOR BINARY AS NewDbfFile

	DIM FieldRec AS DbfFieldMask
	DIM Header AS DbfHdrMask
	
	FieldCounter = 0
	RecordLength = 0

	DbfCreate% = 0  'Set function to failed status

	EOH = &HD
	EODbf = &H1A
	
	FieldRec.Reserved1 = STRING$(4, 0)
	FieldRec.Reserved2 = STRING$(14, 0)

	'Position DBF file for first write

	SEEK NewDbfFile, 33

	'First process the fields

	WHILE NOT EOF(FileLayout)
		LINE INPUT #FileLayout, Temp$
		FieldCounter = FieldCounter + 1
		Location = INSTR(Temp$, " ")
		IF Location < 11 THEN
			FdName$ = LEFT$(Temp$, Location - 1)
		ELSE
			FdName$ = LEFT$(Temp$, 10)
		END IF
		FieldRec.FdName = FdName$ + _
                    STRING$(11 - LEN(FdName$), 0)
		FieldRec.FdType = MID$(Temp$, 11, 1)
		FieldRec.FdLength = _
   	              CHR$(VAL(MID$(Temp$, 12, 3)))
		FieldRec.FdDec = _
		              CHR$(VAL(MID$(Temp$, 15, 2)))
		PUT NewDbfFile, , FieldRec
		RecordLength = RecordLength + _
		                     ASC(FieldRec.FdLength)
	WEND

	CLOSE FileLayout

	PUT NewDbfFile, , EOH  'End of header
	PUT NewDbfFile, , EODbf'End of file

'  Now set the header information

	Header.VersionNumber = CHR$(&H3)
	MID$(Header.Update, 1, 1) = _
	            CHR$(VAL(RIGHT$(DATE$, 4)) - 1900)
	MID$(Header.Update, 2, 1) = _
	                    CHR$(VAL(LEFT$(DATE$, 2)))
	MID$(Header.Update, 3, 1) = _
	                  CHR$(VAL(MID$(DATE$, 4, 2)))
	Header.NbrRec = 0
	Header.HdrLen = FieldCounter * 32 + 33
	Header.RecLen = RecordLength + 1
	Header.Reserved = STRING$(20, 0)

	PUT NewDbfFile, 1, Header 'At beginning of file
	CLOSE NewDbfFile
	DbfCreate = -1       'Successful creation
END FUNCTION

SUB DoDosCall (FileName$)

' If you have QuickBASIC, change all
' occurrences of SSEG to VARSEG.

' DOS requires an ASCIIZ string so add CHR$(0)

	 Spec$ = FileName$ + CHR$(0)
	 InRegs.ds = SSEG(Spec$) ' Load DS:DX with
	 InRegs.dx = SADD(Spec$) ' address of Spec$
	 CALL InterruptX(&H21, InRegs, OutRegs)

END SUB

FUNCTION Exist% (FileName$)

' See if a given file exists using
' DOS "Search for first match" service &H4E

	 InRegs.ax = &H4E00
	 InRegs.cx = 63  ' Search for all files
	 DoDosCall (FileName$)

' If AX contains a value, then file does not exist

	 SELECT CASE OutRegs.ax
		 CASE 0
			 Exist% = -1
		 CASE ELSE
			 Exist% = 0
	 END SELECT

END FUNCTION