$CPU 8086          ' make compatible with XT systems
$LIB ALL OFF       ' turn off all PowerBASIC libraries
$ERROR ALL OFF     ' turn off all PowerBASIC error checking
$OPTIMIZE SIZE     ' optimize for smaller code
 $COMPILE UNIT      ' compile to a UNIT (.PBU)
'$COMPILE EXE       ' compile to a UNIT (.PBU)

DEFINT A-Z         ' Required for all numeric functions, forces PB to not
                   ' include floating point in UNIT (makes it smaller)
'/*------------------------------------------------------------------*/
DECLARE FUNCTION EXIST(BYVAL Filename AS STRING) AS INTEGER
'/*------------------------------------------------------------------*/
' DBCREATE DBNAME$
'     dBase Create.
'     Creates a dBASE III file (header with zero records) using field
'     definitions in DBNAME$ file (a flat or sequential file) where each
'     record represents a dBASE field in the following format:
'     Fieldname, Fieldtype, Fieldlength, Field Decimals
'
'     EXAMPLE:  DBCREATE "ADDRESS"
'
'     where the file ADDRESS looks like
'
'       'NAME, S, 30, 0'
'       'ADDRESS, S, 30, 0'
'       'CITY, S, 16, 0'
'       'STATE, S, 2, 0'
'       'ZIP, S, 10, 0'
'       'MEMBERSHIP, S, 20, 0'
'
'     The file 'ADDRESS.DBF' is created with the header date set to
'     the computer's current date.
'/*------------------------------------------------------------------*/
  DBCREATE DBNAME$
      dBase Create.
      Creates a dBASE III file (header with zero records) using field
      definitions in DBNAME$ file (a flat or sequential file) where each
      record represents a dBASE field in the following format:
      Fieldname, Fieldtype, Fieldlength, Field Decimals

      EXAMPLE:  DBCREATE "ADDRESS"

      where the file ADDRESS looks like

        'NAME, S, 30, 0'
        'ADDRESS, S, 30, 0'
        'CITY, S, 16, 0'
        'STATE, S, 2, 0'
        'ZIP, S, 10, 0'
        'MEMBERSHIP, S, 20, 0'

      The file 'ADDRESS.DBF' is created with the header date set to
      the computer's current date.
    SUB DBCREATE(DBNAME$) PUBLIC
      REDIM DFN$(0:129)
      REDIM DTP$(0:129)
      REDIM DLEN$(0:129)
      REDIM DDC$(0:129)
      IF EXIST(DBNAME$) THEN
'/*     --- Get Data File ---
        DFB = FREEFILE
        CNT = 0
        LRECL = 0
        OPEN"I",DFB,DBNAME$
        DO WHILE NOT EOF(DFB)
          CNT = CNT + 1
          INPUT#DFB, DFN$(CNT),DTP$(CNT),DLEN$(CNT),DDC$(CNT)
          LRECL = LRECL + VAL(DLEN$(CNT))
        LOOP
        CLOSE#DFB
        FCNT = CNT
'/*     --- Set Version to dBASE III ---
        DBH$ = STRING$(1000,0)
        MID$(DBH$,1,1) = CHR$(3)
'/*     --- Create Date Field ---
        YY = VAL(RIGHT$(DATE$,4))
        YY = YY - 1900
        DD = VAL(MID$(DATE$,4,2))
        MM = VAL(MID$(DATE$,1,2))
        MID$(DBH$,2,1) = CHR$(YY)
        MID$(DBH$,3,1) = CHR$(MM)
        MID$(DBH$,4,1) = CHR$(DD)
'/*     --- Number of Records set to 0 ---
        MID$(DBH$,5,4) = MKDWD$(0)
'/*     --- LRECL ---
        MID$(DBH$,11,2) = MKWRD$(LRECL)
'/*     --- Build Field Descriptions ---
        SP = 33
        FOR CNT = 1 TO FCNT
          MID$(DBH$,SP,LEN(DFN$(CNT))) = DFN$(CNT)
          MID$(DBH$,SP+10,1) = DTP$(CNT)
          MID$(DBH$,SP+12,4) = CHR$(0,0,0,0)
          MID$(DBH$,SP+16,1) = MKBYT$(VAL(DLEN$(CNT)))
          MID$(DBH$,SP+17,1) = MKBYT$(VAL(DCC$(CNT)))
          MID$(DBH$,SP+18,13) = STRING$(13,CHR$(0))
          SP = SP + 32
        NEXT CNT
        MID$(DBH$,SP,1) = CHR$(13)
        DBH$ = LEFT$(DBH$,SP)
'/*     --- Put in Header Offset Value ---*/
        MID$(DBH$,9,2) = MKWRD$(SP)
'/*     --- Put in EOF Marker ---*/
        DBH$ = DBH$ + CHR$(26)
'/*     --- Create DBHeader ---
        FB = FREEFILE
        FILENAME$ = DBNAME$ + ".DBF"
        IF EXIST(FILENAME$) > 0 THEN KILL FILENAME$
        OPEN FILENAME$ FOR BINARY ACCESS READ WRITE SHARED AS #FB
        SEEK #FB,0
        PUT$ #FB,DBH$
        CLOSE#FB
      END IF
    END SUB
'/*------------------------------------------------------------------*/
    FUNCTION DBSTRING(DA$(), FD$()) PUBLIC AS STRING
       RTRN$ = " "
       FCNT = VAL(DA$(0))
       FOR CNT = 1 TO FCNT
         FTYPE$ = MID$(FD$(CNT),12,1)
         FLEN = VAL(MID$(FD$(CNT),13,3))
         L = LEN(DA$(CNT))
         IF L > FLEN THEN DA$(CNT) = LEFT$(DA$,L)
         IF L < FLEN THEN DA$(CNT) = DA$(CNT) + STRING$(FLEN-1,32)
         RTRN$ = RTRN$ + DA$(CNT)
       NEXT CNT
       FUNCTION = RTRN$
    END FUNCTION
'/*------------------------------------------------------------------*/
'   $INCLUDE "C:\CODE\MLIB\MLIB.INC"
'   DIM D$(10)
'   T$ = "C:\CODE\MLIB\CREATE"
'   DBCREATE T$
'   FB = FREEFILE
'   DBOPEN FB,T$,LRECL,NRECS#,OFFSET,DFD$()
'   D$(0) = "7"
'   D$(1) = "19551019"
'   D$(2) = "Mark McDonald"
'   D$(3) = "5116 Dillon Street"
'   D$(4) = "Denver"
'   D$(5) = "CO"
'   D$(6) = "80239"
'   D$(7) = " "
'   TD$ = DBSTRING(D$(),DFD$())
'   DBSEEK FB,1,LRECL,OFFSET
'   PUT$ #FB,TD$
'   DBUPDATE FB,1
'   CLOSE#FB
'   DBOPEN FB,T$,LRECL,NRECS#,OFFSET,DFD$()
'   DBSEEK FB,1,LRECL,OFFSET
'   GET$ #FB,LRECL,TB$
'   PRINT "'"TB$"'"
'   INPUT Z
'/*------------------------------------------------------------------*/