'+==============================================+ '| DB.BAS 1/25/88 | '| David Perry | '| QuickBASIC 4.0 Source | '| Compile: BC DB /O/D | '| Link: LINK /EX DB; | '| Opens dBASE III .DBF and .DBT files | '| Reads and displays structure .DBF file | '| Then reads and displays data to include | '| up to first 4000 bytes of memo fields | '| This can be redirected to file or printer | '| by typing DB FILENAME.DBF>FILEDAT or | '| DB FILENAME.DBF>PRN | '| Respects flag for deleted records (may | '| be modified--see source below) | '| This is a simple basis for building QB | '| programs which require reading .DBF files | '+==============================================+ DECLARE SUB Stripchar (a$) REM $DYNAMIC DEFINT A-Z TYPE dBHeader Version AS STRING * 1 'dBaseIII file header Lastupdate AS STRING * 3 '32 bytes NumRecs AS LONG NumBytesHeader AS INTEGER NumBytesRec AS INTEGER Trash AS STRING * 20 END TYPE TYPE FieldDescriptor 'Field Descriptions FName AS STRING * 11 '32 bytes * Number of Fields FType AS STRING * 1 ' Up to 128 DataAddress AS STRING * 4 Length AS STRING * 1 DecimalCount AS STRING * 1 Trash AS STRING * 14 END TYPE CONST TRUE = -1: FALSE = NOT TRUE DELETED = TRUE DIM Header AS dBHeader, FieldDes AS FieldDescriptor 'Creating variables for user-defined types DIM memo AS STRING * 512 'Create a 512 byte fixed string variable ' to read memo fields IF COMMAND$ = "" THEN PRINT "Please enter the name of a database file "; 'Parsing the command line LINE INPUT dbasename$ IF dbasename$ = "" THEN END ELSE dbasename$ = COMMAND$ END IF dbasename$ = UCASE$(dbasename$) dot = INSTR(dbasename$, ".") IF dot THEN dbasename$ = LEFT$(dbasename$, dot - 1) + ".DBF" ELSE dbasename$ = dbasename$ + ".DBF" END IF OPEN dbasename$ FOR BINARY AS #1 'Binary file I/O GET #1, , Header 'This reads in the first 32 bytes SELECT CASE Header.Version CASE CHR$(&H83) 'Be sure we're using a dBASE III file dot = INSTR(dbasename$, ".") dmemo$ = LEFT$(dbasename$, dot - 1) + ".DBT" 'Open a .DBT file if Header.Version=CHR(&H83) OPEN dmemo$ FOR BINARY AS #2 CASE CHR$(&H3) CASE ELSE PRINT "This is not a dBASE III file" END END SELECT Year = ASC(MID$(Header.Lastupdate, 1, 1)) 'Date of last update is stored in 3 bytes Month = ASC(MID$(Header.Lastupdate, 2, 1)) 'The value of year,month,day = ASCII value of the Day = ASC(MID$(Header.Lastupdate, 3, 1)) 'Bytes NumFields = Header.NumBytesHeader \ 32 - 1 'Calculate the number of fields REDIM FieldDes(1 TO NumFields) AS FieldDescriptor 'Create an array of Field Descriptors PRINT "Structure for database: "; dbasename$ PRINT USING "\ \ ##########"; "Number of data records :"; Header.NumRecs PRINT USING "\ \ ##/##/##"; "Date of last update :"; Month; Day; Year PRINT "Field Field Name Type Width Dec" FOR i = 1 TO (NumFields) GET #1, (32 * i) + 1, FieldDes(i) 'Looping through NumFields by reading in 32 byte records SELECT CASE FieldDes(i).FType 'Reading the dBASE Field Type CASE "C" PrintType$ = "Character" CASE "D" PrintType$ = "Date" CASE "N" PrintType$ = "Numeric" CASE "L" PrintType$ = "Logical" CASE "M" PrintType$ = "Memo" END SELECT 'This prints out the field names, lengths, numeric, decimal values as appropriate PRINT USING "##### \ \ \ \ ### ###"; i; FieldDes(i).FName; PrintType$; ASC(FieldDes(i).Length); ASC(FieldDes(i).DecimalCount) NEXT i 'The field names, lengths, and types are read. Now read in the data SEEK #1, Header.NumBytesHeader + 1 'Advance the file pointer to the beginning of the data section FOR i = 1 TO Header.NumRecs 'Now loop through the number of records Record$ = STRING$(Header.NumBytesRec, " ") 'Create a variable string length of length= record length GET #1, , Record$ 'Read in the number of bytes in one record Length = 2 FOR j = 1 TO NumFields 'Now display each field by extracting the correct number of IF LEFT$(Record$, 1) = "*" AND DELETED THEN EXIT FOR 'The leftmost character in each record is ASCII &H2A if record is ' marked as deleted or &H20 if not deleted ' change to NOT DELETED to view all records, DELETED to view only ' non-deleted records a$ = MID$(Record$, Length, ASC(FieldDes(j).Length)) 'Characters for each field SELECT CASE FieldDes(j).FType 'Now assign the fields the correct type CASE "D" 'Date a$ = MID$(a$, 5, 2) + "/" + MID$(a$, 7, 2) + "/" + MID$(a$, 3, 2) PRINT a$ CASE "C" 'Character PRINT a$ CASE "N" 'Turn numeric fields into DOUBLE types IF FieldDes(j).DecimalCount <> " " THEN a# = VAL(a$) / 10 ^ VAL(FieldDes(j).DecimalCount) ELSE a# = VAL(a$) END IF PRINT a# CASE "L" 'assign an integer to logical types IF a$ = "T" OR a$ = "Y" THEN a% = -1 ELSE a% = 0 END IF PRINT a% CASE "M" a& = VAL(a$) 'memo fields contain a pointer to the 512K block IF a& > 0 THEN ' of text in the accompanying .DBT file GET #2, (a& * 512 + 1), memo ' read in 512 bytes offset 512*pointer+1 a$ = memo Escape = INSTR(a$, CHR$(&H1A) + CHR$(&H1A)) 'each .DBT record ends with &H1A&H1A IF Escape THEN 'stop reading in the record if &H1A&H1A a$ = LEFT$(a$, Escape - 1) Stripchar a$ PRINT a$ ELSE 'else keep reading done = FALSE b$ = a$ a& = a& + 1 DO GET #2, (a& * 512 + 1), memo a$ = memo Escape = INSTR(a$, CHR$(&H1A) + CHR$(&H1A)) IF Escape THEN done = TRUE a$ = LEFT$(a$, Escape - 1) Stripchar a$ b$ = b$ + a$ PRINT b$ ELSE Stripchar a$ b$ = b$ + a$ IF LEN(b$) > 4000 THEN done = TRUE 'concatenate to length of 4000 bytes a& = a& + 1 ' which is length of memo text displayable END IF ' in dBASE MODIFY COMMAND editor LOOP UNTIL done END IF END IF END SELECT Length = Length + ASC(FieldDes(j).Length) NEXT j NEXT i CLOSE END REM $STATIC SUB Stripchar (a$) STATIC a = INSTR(a$, CHR$(&HA)) DO WHILE a temp$ = LEFT$(a$, a - 1) temp1$ = RIGHT$(a$, LEN(a$) - a) a$ = temp$ + temp1$ a = INSTR(a$, CHR$(&HA)) LOOP a = INSTR(a$, CHR$(&H8D)) DO WHILE a temp$ = LEFT$(a$, a - 1) temp1$ = RIGHT$(a$, LEN(a$) - a) a$ = temp$ + CHR$(&HD) + temp1$ a = INSTR(a$, CHR$(&H8D)) LOOP END SUB