home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
QBAS
/
IMB9006.ZIP
/
PRINTDBF.BAS
< prev
next >
Wrap
BASIC Source File
|
1990-05-16
|
10KB
|
329 lines
DEFINT A-Z
DECLARE FUNCTION ReadFileStructure% ()
DECLARE FUNCTION RightJust$ (Value$, FieldWidth%)
DECLARE FUNCTION ZeroJust$ (Number AS INTEGER)
DECLARE FUNCTION ReadDbfHdr% ()
DECLARE SUB DspDbfInfo ()
DECLARE SUB DspFileStructure ()
DECLARE SUB Pause ()
DECLARE SUB PrintDbfRecord (fv$(), RecNum%)
DECLARE SUB PrintReport ()
DECLARE SUB ReadDbfRecord (fv$())
'=================================================
'= PROGRAM: PRINTDBF.BAS =
'= PURPOSE: Print listings of 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$
FileName$ = "PLANETS.DBF"
'-------------------------------------------------
' Main processing loop -
'-------------------------------------------------
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
CLS
DspFileStructure
Pause
IF ActionHdr <> 2 THEN
CLS
PrintReport
Pause
ELSE
CLS
PRINT "No records to print"
END IF
CASE False
BEEP
PRINT "Field information error"
END SELECT
END SELECT
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 DspFileStructure
'-------------------------------------------------
'Purpose: Display the structure of the dBASE file-
' Name, Field Type, Length and number -
' of decimals if a number -
'-------------------------------------------------
FieldTitleS$ =_
"Field Field Name Type Width Dec"
FieldString1$ = " ### \ \ "
FieldString2$ = "\ \ ### ##"
PRINT : PRINT FieldTitleS$
FOR I = 1 TO Hdr.NumberFields
PRINT USING FieldString1$; I; FLDS(I).FdName;
SELECT CASE FLDS(I).FdType
CASE "C": ty$ = "Character"
CASE "L": ty$ = "Logical"
CASE "N": ty$ = "Number"
CASE "F": ty$ = "Floating Pt"
CASE "D": ty$ = "Date"
CASE "M": ty$ = "Memo"
CASE ELSE: ty$ = "Unknown"
END SELECT
PRINT USING FieldString2$; ty$;_
FLDS(I).FdLength; FLDS(I).FdDec
NEXT I
PRINT " ** Total **"; TAB(33);
PRINT USING "####"; Hdr.RecordLength
END SUB
SUB Pause
PRINT
PRINT "Press any key to continue"
WHILE INKEY$ = "": WEND
END SUB
SUB PrintDbfRecord (fv$(), RecNum)
'-------------------------------------------------
'Purpose: Print the record to the screen. Left -
' justify character, date and logical -
' fields. Right justify numeric fields -
' and ignore memo fields -
'Input : Field values store in character array, -
' current record number -
'-------------------------------------------------
' Print rec # & delete status
ColumnSpace = 4 'Room between columns
PRINT USING "####### !"; RecNum; fv$(0);
ColumnLocation = 10 'Set current location
FOR I = 1 TO Hdr.NumberFields
IF FLDS(I).FdType <> "M" THEN
PRINT TAB(ColumnLocation);
IF FLDS(I).FdType = "N" OR _
FLDS(I).FdType = "F" THEN
PRINT RightJust$(fv$(I), FLDS(I).FdLength);
ELSE
PRINT fv$(I);
END IF
' Set next print location
ColumnLocation = ColumnLocation +_
FLDS(I).FdLength + ColumnSpace
END IF
NEXT I
PRINT
END SUB
SUB PrintReport
'-------------------------------------------------
'Purpose: Main printing routine -
'Calls : ReadDbfRecord -
' PrintDbfRecord -
'-------------------------------------------------
DIM FieldValues$(Hdr.NumberFields)
PRINT : PRINT
PRINT "Report on the "; FileName$; " file"
PRINT
FOR I = 1 TO Hdr.NumberRecords
CALL ReadDbfRecord(FieldValues$())
CALL PrintDbfRecord(FieldValues$(), I)
NEXT I
END SUB
FUNCTION ReadDbfHdr
'-------------------------------------------------
'Purpose: Read the dBASE file header information -
' and store in the header record - -
'-------------------------------------------------
HdrStr$ = SPACE$(32)
GET #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
Hdr.FileSize = Hdr.HeaderLength + Hdr.RecordLength_
* Hdr.NumberRecords + 1
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
SUB ReadDbfRecord (fv$())
'-------------------------------------------------
'Purpose: Read a dBASE record, format date and -
' logical fields for output -
'Input : Array of Field values -
'-------------------------------------------------
F$ = SPACE$(Hdr.RecordLength)
GET #1, , F$ 'Read the record
fv$(0) = LEFT$(F$, 1) 'Read deleted record mark
FPOS = 2
FOR I = 1 TO Hdr.NumberFields
fv$(I) = MID$(F$, FPOS, FLDS(I).FdLength)
SELECT CASE FLDS(I).FdType 'Adjust field types
CASE "D" 'Modify date format
y$ = LEFT$(fv$(I), 4)
M$ = MID$(fv$(I), 5, 2)
d$ = RIGHT$(fv$(I), 2)
fv$(I) = M$ + "/" + d$ + "/" + y$
CASE "L" 'Standardize T or F
SELECT CASE UCASE$(fv$(I))
CASE "Y", "T": fv$(I) = ".T."
CASE "N", "F": fv$(I) = ".F."
CASE ELSE: fv$(I) = ".?."
END SELECT
CASE ELSE
END SELECT
FPOS = FPOS + FLDS(I).FdLength 'Set next fld
' PRINT fv$(I)
NEXT I
END SUB
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$, FieldWidth)
'-------------------------------------------------
'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$(FieldWidth, " ") +_
Value$, FieldWidth)
END FUNCTION
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