home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
magazine
/
ins_msb
/
9007
/
createdb.bas
next >
Wrap
BASIC Source File
|
1990-06-28
|
4KB
|
192 lines
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