home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
QBAS
/
IMB9008.ZIP
/
WRITEDBF.BAS
< prev
Wrap
BASIC Source File
|
1990-07-12
|
9KB
|
316 lines
DEFINT A-Z
DECLARE FUNCTION ReadDbfHdr% ()
DECLARE FUNCTION ReadFileStructure% ()
DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
DECLARE SUB DspDbfInfo ()
DECLARE SUB InputRecord (R$())
DECLARE SUB Pause ()
DECLARE SUB WriteRecord (R$(), AppendingRecordFlag%)
'=================================================
'= PROGRAM: WriteDBF.BAS =
'= PURPOSE: Write records to dBASE III+/IV =
'= DBF files =
'=================================================
'-------------------------------------------------
' Initialize variables and create types -
'-------------------------------------------------
CONST True = -1, False = 0
TYPE HeaderInfoType
VersionNumber AS INTEGER
LastUpdate AS STRING * 8
NumberRecords AS LONG
HeaderLength AS INTEGER
RecordLength AS INTEGER
NumberFields AS INTEGER
FileSize AS LONG
END TYPE
TYPE FieldInfoType
FdName AS STRING * 11
FdType AS STRING * 1
FdLength AS INTEGER
FdDec AS INTEGER
END TYPE
DIM SHARED Hdr AS HeaderInfoType
DIM SHARED FileName$
'-------------------------------------------------
' Main processing loop -
'-------------------------------------------------
FileName$ = "PLANETS.DBF"
OPEN FileName$ FOR BINARY AS #1
CLS
ActionHdr = ReadDbfHdr
SELECT CASE ActionHdr
CASE 1
BEEP
PRINT "Not a dBASE III+ or IV file"
CASE ELSE
DspDbfInfo
Pause
DIM SHARED Flds(Hdr.NumberFields) AS FieldInfoType
ActionFile = ReadFileStructure
SELECT CASE ActionFile
CASE True
DIM SHARED NewData$(Hdr.NumberFields)
Response$ = ""
RecNbr = Hdr.NumberRecords
DO WHILE UCASE$(Response$) <> "N"
CLS
INPUT "Append record to file (Y/N)"; Response$
IF UCASE$(Response$) = "Y" THEN
RecNbr = RecNbr + 1 'Append Record
CALL InputRecord(NewData$())
CALL WriteRecord(NewData$(), RecNbr)
ActionHdr = ReadDbfHdr
DspDbfInfo
Pause
END IF
LOOP
CASE False
BEEP
PRINT "Field information error"
END SELECT
END SELECT
PRINT "DBF closed"
CLOSE #1
END
SUB DspDbfInfo
'-------------------------------------------------
'Display dBASE file header information -
'-------------------------------------------------
PRINT USING "dBASE Version : #"; Hdr.VersionNumber
PRINT "Database in use : "; FileName$
PRINT USING "Number of data records: ########"; Hdr.NumberRecords
PRINT "Date of last update : "; Hdr.LastUpdate
PRINT USING "Header length : ####"; Hdr.HeaderLength
PRINT USING "Record length : ####"; Hdr.RecordLength
PRINT USING "Number of fields : ###"; Hdr.NumberFields
PRINT USING "File size : ########"; Hdr.FileSize
END SUB
SUB InputRecord (R$())
'-------------------------------------------------
'Prompt user to input all fields for a record -
'-------------------------------------------------
CLS
LOCATE 1, 35: PRINT "Enter Records": PRINT
PRINT "Field Name Type Length";
PRINT " Decimals - Enter Value"
PRINT
Fmt1$ = "\ \ \ \"
Fmt2$ = " ### ## <"
FOR I = 1 TO UBOUND(R$)
IF Flds(I).FdType <> "M" THEN
ExtraOffset = 0
SELECT CASE Flds(I).FdType
CASE "C"
PromptType$ = "Character"
CASE "N"
PromptType$ = "Numeric"
CASE "F"
PromptType$ = "Floating Point"
CASE "L"
PromptType$ = "Logical"
CASE "D"
PromptType$ = "Date (YYYY/MM/DD)"
ExtraOffset = 2
CASE ELSE
END SELECT
PRINT USING Fmt1$; Flds(I).FdName; PromptType$;
PRINT USING Fmt2$; Flds(I).FdLength; Flds(I).FdDec;
PRINT SPACE$(Flds(I).FdLength + ExtraOffset); ">";
LOCATE , POS(0) - Flds(I).FdLength - 1 - ExtraOffset
INPUT "", R$(I)
END IF
NEXT I
END SUB
SUB Pause
'-------------------------------------------------
'Prompt user to press a key to continue -
'-------------------------------------------------
PRINT
PRINT "Press any key to continue"
WHILE INKEY$ = "": WEND
END SUB
FUNCTION ReadDbfHdr
'-------------------------------------------------
'Purpose: Read the dBASE file header information -
' and store in the header record - -
'-------------------------------------------------
HdrStr$ = SPACE$(32)
GET #1, 1, HdrStr$ 'Read dBASE Header
Hdr.VersionNumber = ASC(LEFT$(HdrStr$, 1)) AND (7)
UpdYY$ = ZeroJust$(ASC(MID$(HdrStr$, 2, 1)))
UpdMM$ = ZeroJust$(ASC(MID$(HdrStr$, 3, 1)))
UpdDD$ = ZeroJust$(ASC(MID$(HdrStr$, 4, 1)))
Hdr.LastUpdate = UpdMM$ + "/" + UpdDD$ + "/" + UpdYY$
Hdr.NumberRecords = CVL(MID$(HdrStr$, 5, 4))
Hdr.HeaderLength = CVI(MID$(HdrStr$, 9, 2))
Hdr.RecordLength = CVI(MID$(HdrStr$, 11, 2))
Hdr.NumberFields = (Hdr.HeaderLength - 33) / 32
DataSize = Hdr.RecordLength * Hdr.NumberRecords + 1
Hdr.FileSize = Hdr.HeaderLength + DataSize
IF Hdr.VersionNumber <> 3 THEN
ReadDbfHdr = 1 'Not a dBASE file
EXIT FUNCTION
END IF
IF Hdr.NumberRecords = 0 THEN
ReadDbfHdr = 2 'No records
EXIT FUNCTION
END IF
ReadDbfHdr = 0 'No errors
END FUNCTION
FUNCTION ReadFileStructure
'-------------------------------------------------
'Purpose: Read the file structure store in the -
' dBASE file header. -
'-------------------------------------------------
FOR I = 1 TO Hdr.NumberFields
Fld$ = SPACE$(32)
GET #1, , Fld$ 'Get field info string
Flds(I).FdName = LEFT$(Fld$, 11)
Flds(I).FdType = MID$(Fld$, 12, 1)
Flds(I).FdLength = ASC(MID$(Fld$, 17, 1))
Flds(I).FdDec = ASC(MID$(Fld$, 18, 1))
NEXT I
HeaderTerminator$ = INPUT$(1, #1) 'Last hdr byte
IF ASC(HeaderTerminator$) <> 13 THEN
ReadFileStructure = False 'Bad Dbf header
END IF
ReadFileStructure = True
END FUNCTION
FUNCTION RightJust$ (Value$, FldWidth)
'-------------------------------------------------
'Purpose: Right justify a string by padding it -
' with spaces on the left -
'Input : The character value to justify, the -
' width of the field to fit -
'Output : A right justified string to print -
'-------------------------------------------------
RightJust$ = RIGHT$(STRING$(FldWidth, " ") + Value$, FldWidth)
END FUNCTION
SUB WriteRecord (R$(), RecNbr)
'-------------------------------------------------
'Purpose: Write record to DBF file -
'Input : String array of field contents, R$() -
' Record number to write, RecNbr -
' Appends record to file if greater than -
' number of records currently in file -
'-------------------------------------------------
IF RecNbr > Hdr.NumberRecords THEN 'Appending rec
Offset = (Hdr.NumberRecords) * Hdr.RecordLength
RecPos = Offset + Hdr.HeaderLength + 1
Hdr.NumberRecords = Hdr.NumberRecords + 1
NR$ = MKL$(Hdr.NumberRecords)
PUT #1, 5, NR$
Appending = True
ELSE
Offset = (RecNbr - 1) * Hdr.RecordLength
RecPos = Offset + Hdr.HeaderLength + 1
Appending = False
END IF
EOFchr$ = CHR$(26) 'Set End of File character
R$(0) = " " 'Init to 1 space for the status flag
PUT #1, RecPos, R$(0)
FOR I = 1 TO UBOUND(R$)
IF Flds(I).FdType = "D" THEN
R$(I) = LEFT$(R$(I), 4) + MID$(R$(I), 6, 2)
R$(I) = R$(I) + RIGHT$(R$(I), 2)
END IF
'If Larger than field width
IF LEN(R$(I)) > Flds(I).FdLength THEN
R$(I) = LEFT$(R$(I), Flds(I).FdLength)
ELSEIF LEN(R$(I)) < Flds(I).FdLength THEN
IF INSTR("NF", Flds(I).FdType) <> 0 THEN
' Right justify numbers
R$(I) = RightJust$(R$(I), Flds(I).FdLength)
ELSE
'Else left justify all other field types
R$(I) = R$(I) + SPACE$(Flds(I).FdLength - LEN(R$(I)))
END IF
END IF
PUT #1, , R$(I)
NEXT I
IF Appending THEN 'Add End of record marker
PUT #1, , EOFchr$
END IF
D$ = DATE$
UpdYY$ = CHR$(VAL(RIGHT$(D$, 2)))
PUT #1, 2, UpdYY$
UpdMM$ = CHR$(VAL(LEFT$(D$, 2)))
PUT #1, 3, UpdMM$
UpdDD$ = CHR$(VAL(MID$(D$, 4, 2)))
PUT #1, 4, UpdDD$
PRINT : PRINT "Record written and file updated"
PRINT
END SUB
DEFSNG A-Z
FUNCTION ZeroJust$ (Number AS INTEGER)
'-------------------------------------------------
'Purpose: Add a leading zero to numbers less -
' than 10 so they take as much room as -
' numbers 10 and larger -
'Input : The number to standardize -
'Output : The adjusted number -
'-------------------------------------------------
N$ = STR$(Number)
LengthN = LEN(N$) - 1'Subtract 1 for leading space
N$ = RIGHT$("0" + RIGHT$(N$, LengthN), 2)
ZeroJust$ = N$
END FUNCTION