FoxProUnit

Top  Previous  Next

unit FoxProUnit;

 

interface

 

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, FileCtrl, ComCtrls, ExtCtrls, Grids, Dgrid, Mask, ToolEdit,

Szamok, Szoveg, Math, DBCtrls, DBGrids, Db, DBTables, Gauges, dbf;

 

type

TDataBaseType = (dbtFoxPro, dbtDBase);

 

TFoxHeader  = record

  Azonosito : byte;         // FoxPro = $30 = 48

  ev,ho,nap : byte;

  Rekordszam: longword;

  DataOfset : word;

  Rekordhossz : word;

  Dummi2    : array[0..19] of Char;

end;

 

pStruRec = ^TFoxFieldStru;

TFoxFieldStru  = record

   FieldName : array[0..9] of Char;

   Separator : Char;

   FieldType : Char;

   OfSet     : word;

   Dummi1    : word;

   Size      : byte;

   Dec       : byte;

   Dummi2    : array[0..13] of Char;

end;

 

TOnProgress = procedure(Sender: TObject; Progress: integer) of object;

 

TFoxProExplorer = class(TPersistent)

private

  FFileName: string;

  FOnProgress: TOnProgress;

  FDataBaseType: TDataBaseType;

  FStruGrid: TStDataGrid;

  FDataGrid: TStDataGrid;

  FLoadGrids: boolean;

  function GetFieldCount: integer;

  procedure SetFileName(const Value: string);

  procedure GetRecord(n: integer);

  function GetRecSize: integer;

  function getRecCount: integer;

  function ReadRecordString(No: integer): string;

  procedure DataGridInit;

  procedure StruGridInit;

protected

public

  FieldStru : TList;

  Header    : TFoxHeader;

  StruRecord: TFoxFieldStru;

  fStream   : TFileStream;

  constructor Create;

  destructor Destroy; override;

  procedure GetHeader;

  function GetCharString(sz: array of Char): string;

  procedure AddStru(StruRec: TFoxFieldStru);

  procedure GetStru;

  function CreateDBF(fn: string; OverWrite: boolean; DelAllRecord: boolean): BOOLEAN;

  function IsDBase: boolean;

  property DataBaseType : TDataBaseType read FDataBaseType write FDataBaseType;

  property RecCount     : integer read getRecCount;

  property RecSize      : integer read GetRecSize;

  property FileName     : string read FFileName write SetFileName;

  property FieldCount   : integer read GetFieldCount;

  property DataGrid     : TStDataGrid read FDataGrid write FDataGrid;

  property StruGrid     : TStDataGrid read FStruGrid write FStruGrid;

  property LoadGrids    : boolean read FLoadGrids write FLoadGrids;

  property OnProgress   : TOnProgress read FOnProgress write FOnProgress;

end;

 

implementation

 

{ TFoxProExplorer }

 

procedure TFoxProExplorer.AddStru(StruRec: TFoxFieldStru);

var ARec: pStruRec;

begin

New(ARec);

Arec^.FieldName := StruRec.FieldName;

Arec^.OfSet     := StruRec.OfSet;

Arec^.FieldType := StruRec.FieldType;

Arec^.Size      := StruRec.Size;

Arec^.Dec       := StruRec.Dec;

FieldStru.Add(ARec);

end;

 

constructor TFoxProExplorer.Create;

begin

inherited;

FieldStru := TList.Create;

DataBaseType := dbtFoxPro;

FLoadGrids   := True;

end;

 

destructor TFoxProExplorer.Destroy;

begin

FieldStru.Clear;

FieldStru.Free;

if fStream<>nil then fStream.Free;

inherited;

end;

 

function TFoxProExplorer.GetFieldCount: integer;

begin

Result := FieldStru.Count;

end;

 

procedure TFoxProExplorer.GetHeader;

begin

if fStream<>nil then begin

   fStream.Seek(0,0);

   fStream.Read(Header,SizeOf(Header));

end;

end;

 

procedure TFoxProExplorer.GetStru;

begin

if fStream<>nil then begin

   FieldStru.Clear;

   fStream.Seek(0,SizeOf(Header));

   repeat

     fStream.Read(StruRecord,SizeOf(StruRecord));

     if StruRecord.FieldName[0]<>#13 then

        AddStru(StruRecord)

     else

        exit;

   until False;

end;

end;

 

procedure TFoxProExplorer.SetFileName(const Value: string);

begin

FFileName := Value;

If FileExists(FileName) then begin

   if fStream<>nil then fStream.Free;

   fStream := TFileStream.Create(FileName,fmOpenRead);

   if not IsDBase then begin

   DataBaseType := dbtFoxPro;

   GetHeader;

   GetStru;

   StruGridInit;

   if FLoadGrids then

      DataGridInit;

   end else begin

     fStream.Free;

     DataBaseType := dbtDBase;

   end;

end;

end;

 

  function TFoxProExplorer.GetCharString(sz: array of Char): string;

  var j: integer;

  begin

    Result := '';

    for j:=0 to High(sz) do

      if sz[j]<>#0 then

        Result := Result + sz[j];

  end;

 

 

procedure TFoxProExplorer.StruGridInit;

var i: integer;

begin

IF StruGrid<> nil then begin

   StruGrid.RowCount:= FieldCount+1;

   for i:=1 to FieldCount do begin

      StruRecord := TFoxFieldStru(FieldStru.Items[i-1]^);

      StruGrid.Cells[1,i]:= GetCharString(StruRecord.FieldName);

      StruGrid.Cells[2,i]:= StruRecord.FieldType;

      StruGrid.Cells[3,i]:= IntToStr(StruRecord.Size);

      StruGrid.Cells[4,i]:= IntToStr(StruRecord.Dec);

   end;

end;

end;

 

procedure TFoxProExplorer.GetRecord(n: integer);

begin

if fStream<>nil then begin

   fStream.Seek(0,Header.DataOfset+n*RecSize);

   fStream.Read(Header,SizeOf(Header));

end;

end;

 

{ A No. record string felolvasása a file-ból}

function TFoxProExplorer.ReadRecordString(No: integer): string;

var i: integer;

  s: string;

begin

Result := '';

if fStream<>nil then begin

   fStream.Seek(Header.DataOfset+No*RecSize,0);

   Result := StringOfChar(' ',RecSize);

   For i:=1 to RecSize do

       fStream.Read(Result[i],1);

end;

end;

 

procedure TFoxProExplorer.DataGridInit;

Type pPChar   = ^TData;

   TData    = array of char;

var w          : integer;

  r,i,j,t    : integer;

  d          : integer;

  RecStr     : string;      // Egy record string formában

  Data       : string;

  Progress   : integer;

  oldProgress: integer;

  dInt       : integer;

begin

if (fStream<>nil) and FLoadGrids then

IF DataGrid<>nil then begin

   if RecCount=0 then DataGrid.RowCount:= 2 else

      DataGrid.RowCount:= RecCount+1;

   DataGrid.Row := 1;

   DataGrid.RowClear;

   DataGrid.FixedRows := 1;

   DataGrid.ColCount := FieldCount+1;

   // Mezőneveket ír az adattábla fejlécébe

   for i:=1 to FieldCount do begin

      StruRecord := TFoxFieldStru(FieldStru.Items[i-1]^);

      DataGrid.Cells[i,0]:= GetCharString(StruRecord.FieldName);

      if (StruRecord.Size>=Length(StruRecord.FieldName)) then

         DataGrid.ColWidths[i]:= 8*StruRecord.Size

      else

         DataGrid.ColWidths[i]:= 8*Length(StruRecord.FieldName);

   end;

   // Rekordok felolvasása és adattáblába írás

   Progress := 0;

   oldProgress := 0;

   fStream.Seek(Header.DataOfset,0);

   for r:=0 to RecCount-1 do begin

       RecStr := ReadRecordString(r);

   for i:=1 to FieldCount do begin

      StruRecord := TFoxFieldStru(FieldStru.Items[i-1]^);

      Data := Copy(RecStr,StruRecord.OfSet+1,StruRecord.Size);

 

      if StruRecord.FieldType = 'T' then begin

         dInt :=0;

      for j:=1 To 4 do

         dInt := dInt + Trunc(Power(16,j-1)*ord(Data[j]));

         d :=0;

      for j:=5 To 8 do

         d := d + Trunc(Power(16,j-6)*ord(Data[j]));

      Data := Format('%8d',[dInt])+':'+Format('%8d',[d]);

      end;

 

      if StruRecord.FieldType = 'I' then begin

         dInt :=0;

      for j:=1 to Length(Data) do

         dInt := dInt + Trunc(Power(16,j-1)*Ord(Data[j]));

         Data := Inttostr(dInt);

      end;

 

      DataGrid.Cells[i,r+1]:= Data;

   end;

      Progress := Trunc(100*r/RecCount);

      if Progress<>oldProgress then begin

         oldProgress := Progress;

         if Assigned(FOnProgress) then FOnProgress(Self,Progress);

      end;

   end;

end;

if Assigned(FOnProgress) then FOnProgress(Self,0);

end;

 

 

function TFoxProExplorer.GetRecSize: integer;

begin

Result := TFoxFieldStru(FieldStru.Items[FieldStru.Count-1]^).Ofset

        + TFoxFieldStru(FieldStru.Items[FieldStru.Count-1]^).Size

end;

 

function TFoxProExplorer.getRecCount: integer;

begin

Result := 0;

if fStream<>nil then

   Result := (fStream.Size - Header.DataOfset) div RecSize;

end;

 

function TFoxProExplorer.CreateDBF(fn: string; OverWrite: boolean; DelAllRecord: boolean): BOOLEAN;

var i,j,r,n    : integer;

  dbfTable   : TTable;

  RecStr,Data : string;

  Progress   : integer;

  oldProgress: integer;

  dInt       : integer;

  sFn        : string;

begin

Try

DecimalSeparator := '.';

dbfTable := TTable.Create(Application);

with dbfTable do begin

  Active := False;

  TableType := ttDBase;

  TableName := fn;

 

  // Struktúra létrehozása

  if OverWrite or (not FileExists(fn)) then begin

  with FieldDefs do begin

    Clear;

    for i:=1 to Self.FieldCount do begin

        StruRecord := TFoxFieldStru(FieldStru.Items[i-1]^);

        Try

        with AddFieldDef do begin

             Name := GetCharString(StruRecord.FieldName);

             if StruRecord.FieldType = 'C' then

                DataType := ftString;

             if StruRecord.FieldType = 'N' then

             if StruRecord.Dec=0 then

                DataType := ftSmallInt

             else

                DataType := ftFloat;

             if StruRecord.FieldType = 'L' then

                DataType := ftBoolean;

             if StruRecord.FieldType = 'D' then

                DataType := ftDate;

             if (StruRecord.FieldType = 'M') or

                (StruRecord.FieldType = 'G') then

                DataType := ftMemo;

             if StruRecord.FieldType = 'T' then

                DataType := ftTime;

             if StruRecord.FieldType = 'I' then

                DataType := ftSmallInt;

             Required := False;

             TRY

             Size     := StruRecord.Size;

             Precision:= StruRecord.Dec;

             EXCEPT

             END;

        end;

        except

        end;

    end;

  end;

  CreateTable;

  end;

 

  Exclusive := True;

  Active := True;

 

  if DelAllRecord then

     dbfTable.EmptyTable;

 

 

   // Recordok feltöltése

   progress := 0; oldProgress := 0;

   fStream.Seek(Header.DataOfset,0);

   for r:=0 to RecCount-1 do begin

      RecStr := ReadRecordString(r);

      Append;

      n:=Self.FieldCount-1;

   for i:=0 to n do begin

      StruRecord := TFoxFieldStru(FieldStru.Items[i]^);

      Data := Copy(RecStr,StruRecord.OfSet+1,StruRecord.Size);

      Data := Alltrim(Data);

 

      if Data<>'' then begin

 

      sFn := Alltrim(GetCharString(StruRecord.FieldName));

 

      if ((not OverWrite) and (FindField(sFn)<>nil))

         or OverWrite

      then begin

 

      if StruRecord.FieldType = 'L' then

         if Data='T' then Data := 'True' else Data := 'False';

      if StruRecord.FieldType = 'D' then begin

         if Alltrim(Data)<>'' then

         Data := Copy(Data,1,4)+'.'+Copy(Data,5,2)+'.'+Copy(Data,7,2);

      end;

      if StruRecord.FieldType = 'I' then begin

         dInt :=0;

         for j:=1 to Length(Data) do

             dInt := dInt + Trunc(Power(16,j-1)*Ord(Data[j]));

         Data := Inttostr(dInt);

      end;

 

      Try

         FieldByName(StruRecord.FieldName).AsString:=Data;

      except

      end;

 

      end;

 

      end;

   end;

      Post;

      Progress := Trunc(100*r/RecCount);

      if Progress<>oldProgress then begin

         oldProgress := Progress;

         if Assigned(FOnProgress) then FOnProgress(Self,Progress);

      end;

   end;

 

end;

 

finally

dbfTable.Free;

if Assigned(FOnProgress) then FOnProgress(Self,0);

end;

end;

 

function TFoxProExplorer.IsDBase: boolean;

begin

GetHeader;

Result := not ((Header.Azonosito=$30) or (Header.Azonosito=$31));

end;

 

end.