[cloayza]

Aqui tienes un codigo para crear tu mismo las estructuras de tus archivos dbf, mediante un pequeno trozo de codigo que encontre un dia en la web...

Saludos desde
Concepcion-Chile

Código Delphi [-]
unit MakeDBF;

{
                       MakeDBF unit for Delphi
                             Version 1.10
           Copyright 1995-97 Absolute Computer Consulting,
                         All Rights Reserved.

  Description:
  ------------

   This unit is designed to create a .DBF file header.  It will
   create a table with any number of fields.  It is designed to
   create a dBase IV tables.

  Written by:
  -----------

  Mark Klaamas, Absolute Computer Consulting
  13 Apollo Court
  Halifax, Nova Scotia
  Canada

  Usage:
  ------

    var
      DBF : tCreateDBF;
    begin
      DBF := tCreateDBF.Create;

      try
        with DBF do
        begin

          (* Add fields to the database *)
          AddField('test1', 'C', 10, 0);
          AddField('test2', 'C', 20, 0);
          AddField('test3', 'N', 4, 0);
          AddField('test4', 'N', 6, 2);
          AddField('test5', 'D', 8, 0);
          AddField('test6', 'L', 1, 0);

          (* set the table name *)
          FileName := 'test.dbf';

          (* create the table file. *)
          if not WriteTable then
            MessageDlg('Error occured', mtError, [mbOk], 0);

        end;
      finally
        DBF.Free;
      end;

   end;


  Disclaimer and License:
  -----------------------

    This unit and the associated files can be freely used and
    distributed in commercial and private environments, provided this
    notice is not modified in any way without my expressed written
    consent.  The MakeDBF unit is released as is.  No warranty is
    implied and we are not responsible for any problems that might
    arise from the use of this unit.  You use this unit
    entirely at your own risk.

    Bugs (a.k.a. undocumented features)

    If you find any, please let us know, and we will attempt to fix
    them.  Note that bugs often depend on glitches in the system.
    Sometimes it helps to re-boot and try again...

    Feel free to contact us if you have any questions, comments or
    suggestions at klaamasm@tuns.ca

  Revision History:


  09 Feb 1997:   (v1.10) Finally getting around to fully supporting the
                 full range of field types that dBase allows.

  20 July 1995:  (v1.01) Forced field names to uppercase.  This is to be
                 consistant with FoxPro naming for fields.  Forced a date
                 field to have a length of 8.  Only Numeric fields can
                 be assigned decimal places.

                 Fixed WriteTable routine to correctly detect if the file
                 was created correctly or not.

  11 July 1995:  (v1.00) First release.  Memos will not be supported
                 unless there are requests 

                 Supports following field types: Character, Numeric,
                 Logical, Date.  More will be added on request. }

interface

{ --------------------------------------------------------------------------- }

uses
  SysUtils, Classes;

{ --------------------------------------------------------------------------- }

TYPE

  tCreateDBF = class(tObject)
  private
    fFileName : STRING;
    dbfType   : BYTE;                  { database type                        }
    LangID    : BYTE;                  { Language Driver ID                   }
    Update    : array[0..2] of byte;   { date last updated.                   }
    Rec1Pos   : WORD;                  { position of record 1                 }
    RecLen    : WORD;                  { length of record including delete flg}
    SubRecs   : tList;                 { list of sub records (fields/columns) }
    isMemo    : boolean;               { flag to tell us if there is a memo.  }
    fMemoSize : word;
  public
    constructor Create;
    destructor  Free;
    procedure   AddField(Name : string; fldtype : char; fldsize : byte; dec : byte);
    procedure   UpdateTable;
    function    WriteTable : boolean;
    procedure   ClearAll;

    property    FileName   : string read fFileName write fFileName;
    property    LanguageID : byte   read LangID    write LangID;
    property    MemoSize   : word   read fMemoSize write fMemoSize;
  end;

  {
    Define a sub-record (aka database field/column) class.  Make it a
    class instead of a record so we can add it to a tList without
    doing pointer magic.  It will also make it easier to dispose of
    memory since a tObject "knows" how to dispose of itself.
  }

  tDBFSubRec = class(tObject)
  public
    Name      : array[0..10] of char;  { Field name                           }
    FldType   : char;                  { Field type                           }
    FldDisp   : longint;               { Field displacement in record.        }
    FldLen    : byte;                  { Size of field.                       }
    FldDec    : byte;                  { Number of decimal places.            }
    resv      : array[0..13] of char;  { reserved.                            }
  END;

{ --------------------------------------------------------------------------- }

implementation

{ --------------------------------------------------------------------------- }

const
  ValidTypes = 'BCDFGLMN';             { Character, Numeric, Logical, Date    }

{ --------------------------------------------------------------------------- }

constructor tCreateDBF.Create;
const
  D : pChar = #95#12#28;               { fake an update date.                 }
begin
  fFileName := '';
  dbfType   := 3;                      { FoxPro / dBase 4 table, no memos.    }
  LangID    := $19;                    { magic number ?                     }
  StrCopy(pChar(@update), D);          { set false update date              }
  SubRecs   := tList.Create;           { create a new instance of a tList.    }

  isMemo    := FALSE;
  fMemoSize := 1024;

end; { constructor tCreateDBF.Create }

{ --------------------------------------------------------------------------- }

destructor tCreateDBF.Free;
begin

  SubRecs.Free;                        { Delete the SubRecs and Free Memory.  }

end; { destructor tCreateDBF.Free }

{ --------------------------------------------------------------------------- }

procedure tCreateDBF.AddField(Name : string; fldtype : char; fldsize : byte; dec : byte);
var
  TmpSubRec : tDBFSubRec;
begin

                                       { validate the field type.             }
  fldtype := UpCase(fldtype);

  if pos(fldtype, ValidTypes) = 0 then
    raise Exception.Create('MAKEDBF:  Invalid field type!');

  TmpSubRec := tDBFSubRec.Create;      { create a new field instance.         }

  Name := UpperCase(Name);             { convert field name to UPPERCASE      }
  Move(Name[1], TmpSubRec.Name, Length(Name));
  TmpSubRec.FldType := fldtype;

  with TmpSubRec do
  begin
    FldDisp := 0;                      { ******  updated later.               }
    FldLen  := fldSize;
    FldDec  := 0;

    case fldType of
      'D':           FldLen := 8;
      'M', 'G', 'B': begin
                       FldLen := 10;
                       isMemo := TRUE;
                     end;
      'F', 'N'     : FldDec := Dec;
    end;

    fillchar(resv, sizeof(resv), #0);
  end;

  SubRecs.Add(TmpSubRec);              { add new field to the list.           }

end; { procedure tCreateDBF.AddField }

{ --------------------------------------------------------------------------- }

procedure tCreateDBF.UpdateTable;
var
  x       : integer;
  NumFld  : word;
  RecSize : word;
  TmpFld  : tDBFSubRec;
begin

  { Update the table type }
  if isMemo then
    dbfType := $8B
  else
    dbfType := $03;

  RecSize := 0;                        { account for the delete flag in size  }
  NumFld := SubRecs.Count;

  Rec1Pos := 32 + (32*NumFld) + 1;     { record 1 start position              }

  for x := 0 to (NumFld - 1) do
  begin

    TmpFld := SubRecs.Items[x];

    with TmpFld do
    begin
      FldDisp := RecSize + 1;          { update field displacement in record. }
      RecSize := RecSize + FldLen;
    end;

  end; { for }

  RecSize := RecSize + 1;              { account for the delete flag.         }
  RecLen  := RecSize;                  { set the record length.               }

end; { procedure tCreateDBF.UpdateTable }

{ --------------------------------------------------------------------------- }

function tCreateDBF.WriteTable : boolean;
var
  OutFile  : file;
  x        : word;
  TmpFld   : tDBFSubRec;
  HeadEnd  : char;
  buf      : array[0..31] of char;
  memoBuf  : pChar;
  TmpStr   : string;
begin
  UpdateTable;
  WriteTable := TRUE;
  AssignFile(OutFile, fFileName);

  {$I-}
  if IOResult <> 0 then ;              { clear IOResult                       }
  {

    We need to clear the IOresult because if there was an IOResult that was
    set before we called this method it would cause this method to fail even
    if it worked!

    A little know fact that I didn't know about: according to the manual

    "If an I/O error occurs and I/O-checking is off ( (*$I-*) ), all subsequent
    I/O operations are ignored until a call is made to IOResult. Calling
    IOResult clears the internal error flag."

    However, from testing, if a previous procedure sets IOResult, this procedure
    will run, and work, but still report the IOResult from the previous
    procedure.

  }
  ReWrite(OutFile, 1);

  FillChar(Buf, sizeof(Buf), #0);
  { Setup the memory buffer to resemble the 32 byte dbf header. }
  Move(dbfType, Buf[0], sizeof(dbfType));
  Move(Update, Buf[1], sizeof(Update));
  Move(Rec1Pos, Buf[8], sizeof(Rec1Pos));
  Move(RecLen, Buf[10], sizeof(RecLen));
  Move(LangID, Buf[29], sizeof(LangID));
  BlockWrite(OutFile, Buf, sizeof(Buf));

  for x := 0 to (SubRecs.Count - 1) do
  begin
    TmpFld := SubRecs.Items[x];
    BlockWrite(OutFile, TmpFld.Name,    sizeof(TmpFld.Name));
    BlockWrite(OutFile, TmpFld.FldType, sizeof(TmpFld.FldType));
    BlockWrite(OutFile, TmpFld.FldDisp, sizeof(TmpFld.FldDisp));
    BlockWrite(OutFile, TmpFld.FldLen,  sizeof(TmpFld.FldLen));
    BlockWrite(OutFile, TmpFld.FldDec,  sizeof(TmpFld.FldDec));
    BlockWrite(OutFile, TmpFld.resv,    sizeof(TmpFld.resv));
  end; { for }

  HeadEnd := #13;
  BlockWrite(OutFile, HeadEnd, 1);
  CloseFile(OutFile);

  if isMemo then begin
    { Write out the header for the memo file. }
    AssignFile(OutFile, ChangeFileExt(fFileName, '.DBT'));
    ReWrite(OutFile, 1);

    GetMem(memoBuf, fMemoSize);
    FillChar(memoBuf^, fMemoSize, #0);

    memoBuf[0]   := #01;               { Next free block in memo file.        }
    memoBuf[$12] := #02;               { MAGIC?                               }
    memoBuf[$13] := #01;               { MAGIC?                               }
    memoBuf[$14] := chr(lo(fMemoSize));{ LOW  byte of BLOCK SIZE               }
    memoBuf[$15] := chr(hi(fMemoSize));{ HIGH byte of BLOCK SIZE              }

    { We need the table name. }
    TmpStr := ExtractFileName(fFileName);
    TmpStr := Copy(TmpStr, 1, Length(TmpStr) - 4);
    Move(TmpStr[1], memoBuf[$08], length(TmpStr));

    BlockWrite(OutFile, memoBuf^, fMemoSize);

    FreeMem(memoBuf, fMemoSize);
    CloseFile(OutFile);

  end;

  if IOResult <> 0 then WriteTable := FALSE;
  {I+}
end; { function tCreateDBF.WriteTable : boolean }

{ --------------------------------------------------------------------------- }

procedure tCreateDBF.ClearAll;
begin

  SubRecs.Free;                        { Delete the SubRecs and Free Memory.  }
  SubRecs := tList.Create;

end; { procedure tCreateDBF.ClearAll }

{ --------------------------------------------------------------------------- }

end.