home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 15 / CDACTUAL15.iso / cdactual / program / basic / QBNWS105.ZIP / DB.ZIP / DB.BAS
Encoding:
BASIC Source File  |  1988-01-25  |  8.6 KB  |  199 lines
  1. '+==============================================+
  2. '|   DB.BAS     1/25/88                         |
  3. '|   David Perry                                |
  4. '|   QuickBASIC 4.0 Source                      |
  5. '|   Compile:  BC DB /O/D                       |
  6. '|   Link: LINK /EX DB;                         |
  7. '|   Opens dBASE III .DBF and .DBT files        |
  8. '|   Reads and displays structure .DBF file     |
  9. '|   Then reads and displays data to include    |
  10. '|   up to first 4000 bytes of memo fields      |
  11. '|   This can be redirected to file or printer  |
  12. '|   by typing DB FILENAME.DBF>FILEDAT or       |
  13. '|   DB FILENAME.DBF>PRN                        |
  14. '|   Respects flag for deleted records (may     |
  15. '|   be modified--see source below)             |
  16. '|   This is a simple basis for building QB     |
  17. '|   programs which require reading .DBF files  |
  18. '+==============================================+
  19.  
  20. DECLARE SUB Stripchar (a$)
  21. REM $DYNAMIC
  22. DEFINT A-Z
  23. TYPE dBHeader
  24.    Version AS STRING * 1                                    'dBaseIII file header
  25.    Lastupdate AS STRING * 3                                 '32 bytes
  26.    NumRecs AS LONG
  27.    NumBytesHeader AS INTEGER
  28.    NumBytesRec AS INTEGER
  29.    Trash AS STRING * 20
  30. END TYPE
  31.  
  32. TYPE FieldDescriptor                                        'Field Descriptions
  33.    FName AS STRING * 11                                     '32 bytes * Number of Fields
  34.    FType AS STRING * 1                                      ' Up to 128
  35.    DataAddress AS STRING * 4
  36.    Length AS STRING * 1
  37.    DecimalCount AS STRING * 1
  38.    Trash AS STRING * 14
  39. END TYPE
  40.  
  41. CONST TRUE = -1: FALSE = NOT TRUE
  42. DELETED = TRUE
  43.  
  44. DIM Header AS dBHeader, FieldDes AS FieldDescriptor         'Creating variables for user-defined types
  45. DIM memo AS STRING * 512                                    'Create a 512 byte fixed string variable
  46.                                                             ' to read memo fields
  47. IF COMMAND$ = "" THEN
  48.    PRINT "Please enter the name of a database file  ";      'Parsing the command line
  49.    LINE INPUT dbasename$
  50.    IF dbasename$ = "" THEN END
  51. ELSE
  52.    dbasename$ = COMMAND$
  53. END IF
  54. dbasename$ = UCASE$(dbasename$)
  55. dot = INSTR(dbasename$, ".")
  56. IF dot THEN
  57.    dbasename$ = LEFT$(dbasename$, dot - 1) + ".DBF"
  58. ELSE
  59.    dbasename$ = dbasename$ + ".DBF"
  60. END IF
  61.  
  62. OPEN dbasename$ FOR BINARY AS #1                            'Binary file I/O
  63. GET #1, , Header                                            'This reads in the first 32 bytes
  64. SELECT CASE Header.Version
  65.    CASE CHR$(&H83)                                          'Be sure we're using a dBASE III file
  66.       dot = INSTR(dbasename$, ".")
  67.       dmemo$ = LEFT$(dbasename$, dot - 1) + ".DBT"          'Open a .DBT file if Header.Version=CHR(&H83)
  68.       OPEN dmemo$ FOR BINARY AS #2
  69.    CASE CHR$(&H3)
  70.    CASE ELSE
  71.       PRINT "This is not a dBASE III file"
  72.       END
  73. END SELECT
  74. Year = ASC(MID$(Header.Lastupdate, 1, 1))                   'Date of last update is stored in 3 bytes
  75. Month = ASC(MID$(Header.Lastupdate, 2, 1))                  'The value of year,month,day = ASCII value of the
  76. Day = ASC(MID$(Header.Lastupdate, 3, 1))                    'Bytes
  77.  
  78. NumFields = Header.NumBytesHeader \ 32 - 1                  'Calculate the number of fields
  79.  
  80. REDIM FieldDes(1 TO NumFields) AS FieldDescriptor           'Create an array of Field Descriptors
  81.  
  82. PRINT "Structure for database: "; dbasename$
  83. PRINT USING "\           \  ##########"; "Number of data records  :"; Header.NumRecs
  84. PRINT USING "\           \    ##/##/##"; "Date of last update     :"; Month; Day; Year
  85. PRINT "Field  Field Name     Type   Width  Dec"
  86. FOR i = 1 TO (NumFields)
  87.    GET #1, (32 * i) + 1, FieldDes(i)                        'Looping through NumFields by reading in 32 byte records
  88.    SELECT CASE FieldDes(i).FType                            'Reading the dBASE Field Type
  89.       CASE "C"
  90.          PrintType$ = "Character"
  91.       CASE "D"
  92.          PrintType$ = "Date"
  93.       CASE "N"
  94.          PrintType$ = "Numeric"
  95.       CASE "L"
  96.          PrintType$ = "Logical"
  97.       CASE "M"
  98.          PrintType$ = "Memo"
  99.    END SELECT
  100.             'This prints out the field names, lengths, numeric, decimal values as appropriate
  101.    PRINT USING "#####  \     \   \       \     ###  ###"; i; FieldDes(i).FName; PrintType$; ASC(FieldDes(i).Length); ASC(FieldDes(i).DecimalCount)
  102. NEXT i
  103.  
  104.             'The field names, lengths, and types are read.  Now read in the data
  105.  
  106.  
  107. SEEK #1, Header.NumBytesHeader + 1                          'Advance the file pointer to the beginning of the data section
  108. FOR i = 1 TO Header.NumRecs                                 'Now loop through the number of records
  109.  
  110.    Record$ = STRING$(Header.NumBytesRec, " ")               'Create a variable string length of length= record length
  111.    GET #1, , Record$                                        'Read in the number of bytes in one record
  112.    
  113.    Length = 2
  114.    FOR j = 1 TO NumFields                                   'Now display each field by extracting the correct number of
  115.  
  116.       IF LEFT$(Record$, 1) = "*" AND DELETED THEN EXIT FOR 'The leftmost character in each record is ASCII &H2A if record is
  117.                                                             ' marked as deleted or &H20 if not deleted
  118.                                                             ' change to NOT DELETED to view all records, DELETED to view only
  119.                                                             ' non-deleted records
  120.       a$ = MID$(Record$, Length, ASC(FieldDes(j).Length))   'Characters for each field
  121.       SELECT CASE FieldDes(j).FType                         'Now assign the fields the correct type
  122.          CASE "D"                                           'Date
  123.             a$ = MID$(a$, 5, 2) + "/" + MID$(a$, 7, 2) + "/" + MID$(a$, 3, 2)
  124.             PRINT a$
  125.          CASE "C"                                           'Character
  126.             PRINT a$
  127.          CASE "N"                                           'Turn numeric fields into DOUBLE types
  128.             IF FieldDes(j).DecimalCount <> " " THEN
  129.                a# = VAL(a$) / 10 ^ VAL(FieldDes(j).DecimalCount)
  130.             ELSE
  131.                a# = VAL(a$)
  132.             END IF
  133.             PRINT a#
  134.          CASE "L"                                           'assign an integer to logical types
  135.             IF a$ = "T" OR a$ = "Y" THEN
  136.                a% = -1
  137.             ELSE
  138.                a% = 0
  139.             END IF
  140.             PRINT a%
  141.          CASE "M"
  142.             a& = VAL(a$)                                    'memo fields contain a pointer to the 512K block
  143.             IF a& > 0 THEN                                  ' of text in the accompanying .DBT file
  144.                GET #2, (a& * 512 + 1), memo                 ' read in 512 bytes offset 512*pointer+1
  145.                a$ = memo
  146.                Escape = INSTR(a$, CHR$(&H1A) + CHR$(&H1A))  'each .DBT record ends with &H1A&H1A
  147.                IF Escape THEN                               'stop reading in the record if &H1A&H1A
  148.                   a$ = LEFT$(a$, Escape - 1)
  149.                   Stripchar a$
  150.                   PRINT a$
  151.                ELSE                                         'else keep reading
  152.                   done = FALSE
  153.                   b$ = a$
  154.                   a& = a& + 1
  155.                   DO
  156.                      GET #2, (a& * 512 + 1), memo
  157.                      a$ = memo
  158.                      Escape = INSTR(a$, CHR$(&H1A) + CHR$(&H1A))
  159.                      IF Escape THEN
  160.                         done = TRUE
  161.                         a$ = LEFT$(a$, Escape - 1)
  162.                         Stripchar a$
  163.                         b$ = b$ + a$
  164.                         PRINT b$
  165.                      ELSE
  166.                         Stripchar a$
  167.                         b$ = b$ + a$
  168.                         IF LEN(b$) > 4000 THEN done = TRUE  'concatenate to length of 4000 bytes
  169.                         a& = a& + 1                           ' which is length of memo text displayable
  170.                      END IF                                 ' in dBASE MODIFY COMMAND editor
  171.                   LOOP UNTIL done
  172.                END IF
  173.             END IF
  174.       END SELECT
  175.       Length = Length + ASC(FieldDes(j).Length)
  176.    NEXT j
  177. NEXT i
  178. CLOSE
  179. END
  180.  
  181. REM $STATIC
  182. SUB Stripchar (a$) STATIC
  183. a = INSTR(a$, CHR$(&HA))
  184. DO WHILE a
  185.    temp$ = LEFT$(a$, a - 1)
  186.    temp1$ = RIGHT$(a$, LEN(a$) - a)
  187.    a$ = temp$ + temp1$
  188.    a = INSTR(a$, CHR$(&HA))
  189. LOOP
  190. a = INSTR(a$, CHR$(&H8D))
  191. DO WHILE a
  192.    temp$ = LEFT$(a$, a - 1)
  193.    temp1$ = RIGHT$(a$, LEN(a$) - a)
  194.    a$ = temp$ + CHR$(&HD) + temp1$
  195.    a = INSTR(a$, CHR$(&H8D))
  196. LOOP
  197. END SUB
  198.  
  199.