unit cvgMake;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, db, dbTables;

type
  TMakeDBF = class(TComponent)
  private
    FOutputfile : String;
    FDataSet  : TTable;
    procedure GetOutputfile(Value:String);
    procedure OpenMyOutputFile;
    procedure CloseMyOutputFile;
    procedure WriteProcHeading;
    procedure WriteHeading( dbfname:string );
    procedure DbfID( dbfname: string; path: string);
    procedure WriteFields;
    procedure Createdbf;
    procedure WriteNdxs;
    procedure EndIt;
    procedure WriteProcEnding;
  protected
  public
    constructor Create(AOwner:TComponent);override;
    destructor Destroy;override;
    Procedure Execute;
  published
    Property Outputfile : String read FOutputfile write GetOutputfile ;
    Property DataSet : TTable read FDataSet write FDataSet ;
end;


procedure Register;


implementation
var
    F: System.text;  {outputfile}
    SpeechMark: string;

function Strip(unitname: string): string;
var
  posit : integer;
  crutch: string ;
begin
  crutch := unitname;
  while Pos('\',crutch)>0 do
  begin
  posit := pos('\', crutch);
  crutch:= copy(crutch, posit+1, length(crutch)-posit);
 end;
 if Pos('.',crutch)>0 then
 crutch := copy(crutch, 0, Pos('.',crutch)-1 );
 Result := crutch;
end;

procedure Register;
begin
     RegisterComponents('Data Access',[TMakeDBF]);
end;

constructor TMakeDBF.Create(AOwner:TComponent);
begin
     inherited Create(AOwner);
end;

destructor TMakeDBF.Destroy;
begin
     inherited Destroy;
end;

procedure TMakeDBF.GetOutputfile(Value:String);
begin
 if value <> FOutputFile then
  begin
   FOutputFile := Value;
  end;
end;

procedure TMakeDBF.OpenMyOutputFile;
begin
 System.Assign(F, Foutputfile);
 Rewrite(F);
end; {open myoutputfile}

procedure TMakeDBF.CloseMyOutputFile;
begin
  System.Close(F);
end;  {closemyoutputfile}

procedure TMakeDBF.WriteProcHeading;
begin
  Writeln(F,'unit '+ Strip(Foutputfile)+ ';' );
  Writeln(F,'  ');
  Writeln(F,'{This unit needs to be added to your uses clause and then called}');
  Writeln(F,'{say from a button click on your form}  ');
  Writeln(F,'  ');
  Writeln(F,'interface ');
  Writeln(F,'uses ');
  Writeln(F,'SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, ');
  Writeln(F,'Forms, Dialogs, Buttons, Menus, ExtCtrls, db, DBTables; ');
  Writeln(F,'  ');
  Writeln(F,'procedure CreateFiles;  ');
  Writeln(F,'  ');
  Writeln(F,'implementation  ');
  Writeln(F,'  ');
  Writeln(F,'procedure CreateFiles;  ');
  Writeln(F,'begin  ');
end; {WriteProcHeading}

procedure TMakeDBF.WriteHeading( dbfname:string);
begin
  Writeln(F,'{--------------------------------------------------------------------}');
  Writeln(F,'{'+dbfname   +' }');
  Writeln(F,'{                                                                    }');
  Writeln(F,'{--------------------------------------------------------------------}');
end;

procedure TMakeDBF.DbfID( dbfname: string; path: string);
begin
  speechmark := '''';
  Writeln(F,' with TTable.Create(Application) do ');
  Writeln(F,'   begin ');
  Writeln(F,'     Active := False; ');
  Writeln(F,'     DatabaseName := '+ speechmark +path +speechmark  + ';' );
  Writeln(F,'     TableName := '+speechmark + dbfname + speechmark + ';' );
  Write  (F,'     TableType := ');
    case DataSet.TableType of
        ttDefault: writeln(F, 'ttDefault;') ;
        ttDBase: writeln(F, 'ttDBase;');
        ttParadox: writeln(F, 'ttParadox;');
        ttAscii: messagedlg('ttASCII is not supported', mtError,[mbOK], 0);
    end;
  Writeln(F,'     with FieldDefs do ');
  Writeln(F,'       begin ');
  Writeln(F,'         Clear; ');
end;

Procedure TMakeDBF.WriteFields;
var
  i: integer;     {loop controller}
  tops: integer;  {no of fields}
  D: TfieldDef;   {for convenvience, field in quest}
begin
  speechmark := '''';
  DataSet.active:=true;
  with DataSet do
  begin
    tops := FieldDefs.count;
    for i:=0 to tops-1 do
      begin
      D := FieldDefs.items[i];
      write(F,'         Add('+SpeechMark+D.name+SpeechMark);
      write(F, ', ');
        case D.DataType of
        ftUnknown: write(F, 'ftUnknown') ;
        ftString: write(F, 'ftString');
        ftSmallint: write(F, 'ftSmallInt');
        ftInteger: write(F, 'ftInteger');
        ftWord: write(F, 'ftWord');
        ftBoolean:write(F, 'ftBoolean');
        ftFloat: write(F, 'ftFloat');
        ftCurrency:write(F, 'ftCurrency');
        ftBCD: write(F, 'ftBCD');
        ftDate: write(F, 'ftDate');
        ftTime: write(F, 'ftTime');
        ftDateTime: write(F, 'ftDateTime');
        ftBytes: write(F, 'ftBytes');
        {ftVarBytes: D := ''; }
        ftBlob:write(F, 'ftBLOB');
        ftMemo: write(F, 'ftMemo');
        ftGraphic: write(F, 'ftGraphic');
        end;
      write(F, ',  ');
      write(F, D.size);
      writeln(F, ', false);');
      end;
    end;
  end;
procedure TMakeDBF.CreateDbf;
begin
  Writeln(F,'       end; ');
  Writeln(F,'     CreateTable; ');
  Writeln(F,'       with IndexDefs do ');
  Writeln(F,'         begin ');
  Writeln(F,'           Clear; ');
end;

procedure TMakeDBF.WriteNdxs;
var
  tops: integer;
  i:    integer;
  N:    TIndexDefs;
  S:    String;
  S1:   String;
begin
  with DataSet do
  begin
  IndexDefs.Update;
  tops := IndexDefs.Count;
  for i := 0 to tops-1 do
    begin
     { N:= IndexDefs.items[i]; }
      write(F,'           Addindex('+SpeechMark+IndexDefs.items[i].Name+SpeechMark);
      Write(F, ', '+SpeechMark);
      write(F, IndexDefs.items[i].Fields+IndexDefs.items[i].Expression);
      write(F, SpeechMark+', [');
           S:='';
          if ixPrimary in IndexDefs.items[i].Options then
            S:='ixPrimary, ';
          if ixUnique in IndexDefs.items[i].Options then
            S := S + 'ixUnique, ';
          if ixDescending in IndexDefs.items[i].Options then
            S := S + 'ixDescending, ';
          if ixCaseInsensitive in IndexDefs.items[i].Options then
            S := S + 'ixCaseInsensitive, ';
          if ixExpression in IndexDefs.items[i].Options then
            S := S + 'ixExpression, ';
         {Get rid of trailing ", "}
         S := Copy(S, 1, length(s)-2);
      write(F, s);
      writeln(F, ']);' );
    end;
  end;
end;

procedure TMakeDBF.Endit;
begin
  Writeln(F,'          end;');
  Writeln(F,'        end;');
end;

procedure TMakeDBF.WriteProcEnding;
begin
  Writeln(F,'end; ');
  Writeln(F,'  ');
  Writeln(F,'end. ');
end; {WriteProcEnding}

Procedure TMakeDBF.Execute;
begin
  OpenMyOutputFile;
  WriteProcHeading;
  WriteHeading(DataSet.Tablename);
  DbfID(DataSet.Tablename,DataSet.DatabaseName);
  WriteFields;
  Createdbf;
  WriteNdxs;
  EndIt;
  WriteProcEnding;
  CloseMyOutputFile;
end;
end.

