unit dbfu;{see !!! for to fix parts}
{ just for sequential reading/writing to existing dbf, no indexes etc.;
  used by CZ .DLL }
{$I DEFINE.PAS}

{$DEFINE SELECT}
  { support for selection/unselection of records }

interface
uses
  SysUtils, Classes,
  UtlType, WinUtl, Errors, Stru, Msgu, LogType, Dateu,
  DBType, DBFType
  ;

type
  EDBF = class(Exception);

{Interface to access dbf used by dbu}
{EXPORT}
function DBFCreate(const AFileName: TFileName; AFields:PDBFFields; AFieldCount:integer): TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFInit(const AFileName: TFileName; var ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFFirst(ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFNext(ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFLast(ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFPrior(ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFPost(ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetFld(ADBF:pointer; AFieldName:TFldName):TFldNum;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetStr(ADBF:pointer; J:TFldNum):TFldStrVal;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetNum(ADBF:pointer; J:TFldNum):TFldNumVal;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetInt(ADBF:pointer; J:TFldNum):TFldIntVal;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFSetStr(ADBF:pointer; J:TFldNum; AValue:TFldStrVal):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFSetNum(ADBF:pointer; J:TFldNum; AValue:TFldNumVal):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFSetInt(ADBF:pointer; J:TFldNum; AValue:TFldIntVal):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetProp(ADBF:pointer; tp:TTblProperty; APValue:pointer; ASize:TBufSize):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFSetProp(ADBF:pointer; tp:TTblProperty; APValue:pointer; ASize:TBufSize):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFGetPropInt(ADBF:pointer; tp:TTblProperty):longint;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFSetPropInt(ADBF: pointer; tp: TTblProperty; AValue: longint): TTblResult;

function DBFGetPropStr(ADBF:pointer; tp:TTblProperty):string;
  {$IFDEF PMODE}export;{$ENDIF}
function DBFDone(var ADBF:pointer):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}

function DBFScan(const AFileName: TFileName;
  ATblScanOptions: PTblScanOptions; ACallBack:PTblEventHandler):TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}

(*
function DBFsScan(const ABaseFileName: string;
  var AFromMonth: TDateString; var AToMonth: TDateString;
  ATblScanOptions:PTblScanOptions; ACallBack: PTblEventsHandler): TTblResult;
  {$IFDEF PMODE}export;{$ENDIF}
  { scan monthly tables with ABaseFileName (should include dir) in the period
    AFromMonth - AToMonth. If AFromMonth = '' then from the first existing
    table will be scanned, if AToMonth = '' then to the last existing
    table (most probably this month). In these cases (empty AFromMonth
    or AToMonth)  these variables will be set to the found values.
    See dbtype.TTblScanOptions for possible options. Using nil for
    ATblScanOptions defaults will be used. If ACallBack non nil, then
    this procedure will be called upon every DBF event. Use
    tpAfterOpen, tpOnCalcFields }
  *)

function DBFGetFldStr(ADBF: pointer; const AFieldName:TFldName): string;
function DBFSetFldStr(ADBF: pointer; const AFieldName: TFldName; const AValue: string): TTblResult;
function DBFAppend(ADBF: pointer): TTblResult;
function DBFZap(ADBF: Pointer): TTblResult;

function DBFGetFldInt(ADBF: pointer; const AFieldName:TFldName): TFldIntVal;
function DBFGetFldNum(ADBF: pointer; const AFieldName:TFldName): TFldNumVal;
function DBFSetFldInt(ADBF: pointer; const AFieldName: TFldName; const AValue: TFldIntVal): TTblResult;
function DBFSetFldNum(ADBF: pointer; const AFieldName: TFldName; const AValue: TFldNumVal): TTblResult;

{/v1.02}
{/Interface}
{/EXPORT}
type
  TDBFFile = class;
  {$IFDEF SELECT}
  TSelInfo = class(TObject)
    SelFldNr: integer;
    DBF:TDBFFile;
    constructor Create(ADBFFile: TDBFFile);
    destructor Destroy; override;
    procedure Select(OnOff:boolean);
    function Selected:boolean;
  end;
  {$ENDIF}

  string10 = string[10];
  string8  = string[8];

  TDBFFile = class(TObject)
    FileName     : string[64]; {name of DBF file}
    dFile        : TFileStream;
    mFile        : file;
    Head         : TDBFHead; {dbf file header, see dbftypes unit}
    dStatus      : byte;
    WithMemo     : Boolean;  {indicates if DBF file has memo field}
    DateOfUpdate : string8;
    NumRecs      : TRecordCount;  {number or records in database}
    HeadLen      : Integer;  {length of header in DBF file}
    RecLen       : Integer;  {length of record}
    NumFields    : TFieldCount;  {number of fields in record}
    Fields       : PDBFFields;    {record of field headers as found in .DBF file}
    RecNumber    : LongInt;  {number of CurRecord in database}
    CurRecord    : PDBFRecord; {active record from database}
    DelFlag      : boolean;
    dbfError     : Integer; {code of the last error encountered}

    CurNumFields:integer;
    CurFieldAddress:longint;{used during create}

    ShowDeleted:boolean;

    FScanned: boolean;
      { Through all records to find out how many records are un/deleted? }
    FUsedRecs: longint;

    BrowseHeader: string;
    {$IFDEF SELECT}
    SelInfo: TSelInfo;
    {$ENDIF}
    constructor Create(FName : string); overload;
    procedure UpdateFieldDef;
      { Recalculates Fields^[i].A values }

    {constructor for creating a new dbf structure from predefined
       (and allocated for the new dbf) record structure}
    constructor CreateIndirect(FName : string; AFields : PDBFFields; FCnt : integer;
      AllocateCopy:boolean);
    constructor CreateCopy(FName, Template: string); {create file FName with structure of .dbf file Template}

    {following 3 procs used for creating dbf structure in steps:}
    constructor Create(FName: string; FCnt: integer); overload;{FCnt maximal number
      of fields expected = max. number of allowed following CreateField calls}
    procedure CreateField(AFieldName: string10; AFieldType: Char;
                            AFieldLen: Byte; AFieldDec: Byte);
     {after last CreateField call, CreateDone should be called}
    procedure CreateDone;

    PROCEDURE Delete;
    function NewRec:boolean;{clears CurRecord, set RecNumber to New_Record}
    function CopyRecordFrom(ADBFFile:TDBFFile):boolean;
    function GetRec(RecNum: LongInt):boolean;
      {.. get record from database to CurRecord, can be absolute RecNo, or relative:
        Next_Record, Prev_Record, Top_Record, Bottom_Recordl}
    function IsValidRecord:boolean;
      { returns true for RecNumber <> NoRecord}
    function CheckValidRecord:boolean;
      { as IsValidRecord but reports error if is not valid }
    function CheckFieldNum(AFldNum:TFldNum):boolean;
      { Checks if AFldNum is in range, reports error if not }
    function CheckFileStatus:boolean;
      { called after each dFile move to check dFile.Status, reports error }

    PROCEDURE Append; {appends CurRecord to database}
    PROCEDURE Close;
    PROCEDURE Open;
    PROCEDURE PutRec(RecNum : LongInt); {put CurRecord to database, position RecNum}
    procedure SaveRec;{save changes made by PutFieldValue in CurRecord to file}
    procedure Truncate(ARecNum: LongInt); {cut off all records after record RecNum}
    PROCEDURE UnDelete;
    destructor Destroy; override;

    function UsedRecs:longint;
    function BrowseInit(const ADefName:string): TTblResult;
    function BrowseLine: string;
    procedure BrowseDone;

      {procs for manipulating fields in CurRecord:}
    function GetFieldValue(AFieldNum:Byte):string;
    procedure PutFieldValue(AFieldNum:Byte; Value:string);
    function GetFieldNumValue(AFieldNum:Byte):TFldNumVal;
    function PutFieldNumValue(AFieldNum:byte; Value:TFldNumVal):TTblResult;

    function GetFieldNum(AFieldName:string10):byte;
    function GetFieldName(AFieldNum:byte):string10;
    function GetFieldType(AFieldNum:byte):char;

    procedure SetResult(tr:TTblResult; const msg:string);
    procedure ClearResult;

    function GetProp(tp:TTblProperty; APValue:Pointer; ASize:TBufSize):TTblResult;
    function SetProp(tp:TTblProperty; APValue:Pointer; ASize:TBufSize):TTblResult;

    private
    procedure StreamOpen;
    procedure StreamClose;
    function GetDateString(mm,dd,yy:word):String8;
    procedure CreateFile(const FName: TFileName);
    procedure MakeHeader;

    {$IFDEF SELECT}
    function SelInit: boolean;
    procedure SelDone;
    procedure RecordSelect(OnOff:boolean);
    function RecordSelected:boolean;
    {$ENDIF}
  end;


const
  {v1.01}
  DataDir: string = '';
  {/v1.01}
  GlobalString:shortstring = '';
  StreamBufferSize = 1024;

  stNotOpen = 0;
  stNotUpdated = 1;
  stUpdated= 2;

  No_Record = 0;{not initialized record}
  New_Record = -5;{initialized not yet save new record}
  Next_Record = -1;
  Prev_Record = -2;
  Top_Record  = -3;
  Bottom_Record = -4;


{DBF Error constants}
  deBadFileStructure = 157;
  deFileCreation = 158;
  deOutOfMemory = 159;
{ deReadBeyondEOF = 100;}
  deFileNotFound = stInitError;{-2}
  deAccessError = stError;{-1}
  deReadBeyondEOF = stReadError;{-3}
  deWriteError = stWriteError; {-4}

  deNoFilterMatch = 200;
  deIndexNotSet = 201;
  deInvalidRecordNumber = 202;
{var
  DBFInterface: TDataInterface;}

implementation

{$IFNDEF GHS}
{Msgu}
procedure SysError(msg:string);
begin
  Writeln(msg);
end;
{/Msgu}

procedure FreePString(PointerToPString:pointer);
var
  PtrToPString  : ^PString absolute PointerToPString;
begin
  if PtrToPString = nil then
    exit;
  DisposeStr(PtrToPString^);
  PtrToPString^ := nil;
end;

function FExists(FileName: PathStr): Boolean;
{$IFNDEF WINDOWS}
var
  F: file;
  Attr: Word;
{$ENDIF}
begin
  {$IFDEF WINDOWS}
  FExists := FileExists(FileName);
  {$ELSE}
  {ioError:=0;}
  Assign(F, FileName);
  GetFAttr(F, Attr);{sysutils}
  FExists := (DosError = 0);
  {$ENDIF}
end;

function GetString(APString:PString):string;{returns '' for nil, otherwise APString^}
begin
  if APString = nil then
    GetString := ''
  else
    GetString := APString^
end;

function SetString(var APString:PString; AString:string):boolean;
begin
  SetString := false;
  DisposeStr(APString);
  APString := nil;
  if AString <> '' then begin
    APString := NewStr(AString);
    if APString = nil then
      exit;
  end;
  SetString := true;
end;

{/MyLib}

{Stru}
function Trim(const S: string): string;
var l, r: integer;
begin
  if length(S) > 0 then begin
    l := 1;
    r := length(S);
    while (l <= r) and (S[l] = ' ') do inc(l);
    while (r > l) and (S[r] = ' ') do dec(r);
    Trim := copy(S, l, r - l + 1);
  end else
    Trim := ''
end;

function Pad(S : String; Len : Byte) : String;
var
  SLen : Byte absolute S;
begin
  if SLen > Len then
    SLen := Len
  else
    while SLen < Len do
      S := S + ' ';
  Pad := S;
end;

function IntToStr(i:Longint):string;
var s: string[12];
begin
  str(i, s);
  IntToStr := s;
end;
{/Stru}

{Fileu}
const
  fpExt = 2;
  fpDir = 3;

type
  TFileNamePart = word;

function AddBackSlash(Dir : DirStr): DirStr;
begin
  if (Dir <>  '') and (Dir[Length(Dir)] <> '\') then begin
    if (Length(Dir) <> 2) or (Dir[2] <> ':') then Dir := Dir + '\';
  end;
  AddBackSlash := Dir;
end;


{winutl}
{$ENDIF}
const
  GLastResult:TTblResult = trOK;

procedure GClearResult;
begin
  GLastResult := trOK;
end;

procedure GSetResult(tr:TTblResult; const msg:string);
begin
  if tr <> trOK then begin
    {$IFDEF GHS}
    case tr of
     trEOF, trBOF:;
    else
      SysError('DBF Error :' + IntToStr(tr));
    end;
    {$ENDIF}
  end;
  GLastResult := tr;
end;


CONST
  DB3File = 3;
  DB3WithMemo = $83;

  EofMark : Byte = $1A;
  EohMark : Byte = $0D;

{***** Fields procedures, work on CurRecord, fields numbered from 1 ******}
{copy value of field number AFieldNum to Value variable, in Len max allowed
len for copy to value, returns len copied}
function TDBFFile.GetFieldValue(AFieldNum:Byte):string;{; Value:PChar; var Len: Word);}
begin
  if CheckValidRecord and CheckFieldNum(AFieldNum) then begin
    move(CurRecord^[Fields^[AFieldNum].A], GlobalString[1], Fields^[AFieldNum].L);
    SetLength(GlobalString, Fields^[AFieldNum].L);
    GetFieldValue := GlobalString;
 end else
   GetFieldValue := '';
end;


{returns position number of the field with name AFieldName in record structure}
function TDBFFile.GetFieldNum(AFieldName: string10): byte;
var i, j: byte;
begin
  j:=0;
  for i := 1 to NumFields do begin
    if GetFieldName(i){Fields^[i].N} = AFieldName then begin
      j := i;
      break;
    end;
  end;
  GetFieldNum:=j;
end;

{copy new value to field with pos. number AFieldNum from variable Value,
 len - input len of variable, returns accepted len}
procedure TDBFFile.PutFieldValue(AFieldNum:Byte; Value:string);{PChar; var Len:Word);}
var r:real;code:integer;
begin
  if CheckValidRecord and CheckFieldNum(AFieldNum) then begin
    if Fields^[AFieldNum].T = 'N' then begin
      val(Trim(Value),r , code);
      str(r:Fields^[AFieldNum].L:Fields^[AFieldNum].D, Value);
      {Value := lpad(trim(Value), Fields^[AFieldNum].L);}
    end else begin
      Value := Pad(Value, Fields^[AFieldNum].L);
    end;
    move(Value[1], CurRecord^[Fields^[AFieldNum].A], Fields^[AFieldNum].L);
  end;
end;

function TDBFFile.GetFieldNumValue(AFieldNum:Byte):TFldNumVal;
var
  r:TFldNumVal;
  code:integer;
begin
  val(trim(GetFieldValue(AFieldNum)), r, code);
  if (dbfError = trOK) and (code <> 0) then begin
    SetResult(trInvalidNumericFormat, GetFieldValue(AFieldNum));
  end;
  GetFieldNumValue := r;
end;

function TDBFFile.PutFieldNumValue(AFieldNum:byte; Value:TFldNumVal):TTblResult;
var s: string;
begin
  if CheckValidRecord and CheckFieldNum(AFieldNum) then begin
    str(Value:Fields^[AFieldNum].L:Fields^[AFieldNum].D, s);
    PutFieldValue(AFieldNum, s);
    PutFieldNumValue := dbfError;
  end else begin
    Result := -1;
  end;
end;

{returns name of the field of position AFieldNum in record structure}
function TDBFFile.GetFieldName(AFieldNum:byte):string10;
begin
  GetFieldName := StrPas(Fields^[AFieldNum].N);
end;

function TDBFFile.GetFieldType(AFieldNum:byte):char;
begin
  GetFieldType:= Fields^[AFieldNum].T;
end;
{******** end of field procedures *****************************************}

function TDBFFile.GetProp(tp:TTblProperty; APValue:Pointer; ASize:TBufSize):TTblResult;

  function CS(s:TBufSize):boolean;
  begin
    if ASize < s then begin
      SetResult(trInvalidPropBufSize,'');
      CS := false;
    end else
      CS := true;
  end;

begin
  {v1.01}
  if tp <> tpLastResult then
  {/v1.01}
  begin
    ClearResult;
    case tp of
      tpFieldCount: if CS(sizeof(TFieldCount)) then
        PFieldCount(APValue)^ := NumFields;
      tpRecordCount: if CS(sizeof(TRecordCount)) then
        PRecordCount(APValue)^ := NumRecs;
      (tpFieldName+1)..(tpFieldName+DBFMaxFieldCount): begin
        if CS(sizeof(TFldName)) then
          PFldName(APValue)^ := GetFieldName(tp - tpFieldName)
      end;
      tpRecordDeleted: if CS(sizeof(boolean)) then
        PBoolean(APValue)^ := DelFlag;
      tpRecordSelected: begin
        PBoolean(APValue)^ := RecordSelected;
      end;
    else
      SetResult(trInvalidGetProp, IntToStr(tp));
    end;
  end {v1.01}else begin
    if CS(sizeof(dbfError)) then
      PInteger(APValue)^ := dbfError;
  end{/v1.01};
  GetProp := dbfError;
end;

function TDBFFile.SetProp(tp:TTblProperty; APValue:Pointer; ASize:TBufSize):TTblResult;
  function CS(s:TBufSize):boolean;
  begin
    if ASize < s then begin
      SetResult(trInvalidPropBufSize,'');
      CS := false;
    end else
      CS := true;
  end;

begin
  ClearResult;
  case tp of

    tpRecordDeleted: if CS(sizeof(boolean)) then begin
      if PBoolean(APValue)^ then
        Delete
      else
        Undelete;
    end;
    tpRecordSelected: begin
      RecordSelect(PBoolean(APValue)^);
    end;

  else
    SetResult(trInvalidSetProp, IntToStr(tp));
  end;
  SetProp := dbfError;
end;

procedure TDBFFile.ClearResult;
begin
  dbfError := trOK;
  {v1.01}
  GLastResult := trOK;
  {/v1.01}
end;

procedure TDBFFile.SetResult(tr:TTblResult; const msg:string);
begin
  if tr <> trOK then begin
    GSetResult(tr, msg);
  end;
  dbfError := tr;
end;

procedure TDBFFile.Truncate(ARecNum: LongInt); {cut off all records after record RecNum}
{var l : LongInt;}
begin
  ClearResult;
  if ARecnum <> 0 then begin
    GetRec(ARecNum);
  end else begin
    try
      dFile.Seek(HeadLen, soFromBeginning);
    except
      SetResult(-1,'Truncate Seek Failed');
    end;
  end;
  if dbfError <> trOK then
    exit;
  try
    dFile.Size := dFile.Position;
  except
    SetResult({dFile.Status}-1,'Truncate Size = Position');
  end;
  if dbfError <> 0 then
    exit;
  NumRecs:= ARecNum;
  RecNumber:= ARecNum;
  dStatus := stUpdated;
end;

function TDBFFile.NewRec:boolean;{clears CurRecord, set RecNumber to New_Record}
begin
  RecNumber := New_Record;
  FillChar(CurRecord^, RecLen, ' ');
  NewRec := true;
end;

function TDBFFile.CopyRecordFrom(ADBFFile:TDBFFile):boolean;
begin
  CopyRecordFrom := false;
  if ADBFFile = nil then
    exit;
  if RecLen = ADBFFile.RecLen then begin
    Move(ADBFFile.CurRecord^, CurRecord^, RecLen);
    CopyRecordFrom := true;
  end;
end;

function TDBFFile.GetRec(RecNum: LongInt): boolean;
VAR
{  Res: Integer;}
  RNum: LongInt;
label
  er;
BEGIN
  GetRec := false;
  RNum := No_Record;
  {v1.01}ClearResult;
  {/v1.01
  RNum := RecNum;
  if RNum = 0 then
    RNum := Top_Record; }
  repeat
    case {v1.01}RecNum{/v1.01 RNum} of
      Next_Record : begin
        RNum := RecNumber + 1;
        if RNum > NumRecs then begin
          {RNum := 0}
          SetResult(trEOF, '');
          goto er;{RNum := NumRecs;}
        end;
      end;
      Prev_Record : begin
        RNum := RecNumber - 1;
        if RNum < 1 then begin
          SetResult(trBOF, '');
          goto er;
        end; {RNum := 1;}
      end;
      Top_Record  : begin
        if NumRecs > 0 then begin
          RNum := 1;
          {v1.01}{/v1.01 ClearResult;}
        end else begin
          {RNum := 0;}
          SetResult(trEOF, '');
          goto er;
        end;
      end;
      Bottom_Record : begin
        if NumRecs > 0 then begin
          RNum := NumRecs;
          {ClearResult;}
        end else begin
          {RNum := 0;}
          SetResult(trEOF, '');
          goto er;
        end;
      end;
    {v1.01}
    else
      RNum := RecNum;
    {/v1.01}
    end;
    if (RNum < 1) or (RNum > NumRecs) then
    begin
      SetResult(trReadBeyondEOF,'')  {Disk read beyond EOF};
      goto er;
    end;
    dFile.Seek(HeadLen + (RNum - 1) * RecLen, soFromBeginning);
    if not CheckFileStatus then
      goto er;
    dFile.ReadBuffer(CurRecord^, RecLen);
    if not CheckFileStatus then
      goto er;
    RecNumber := RNum;
    if CurRecord^[0] = UnDeleteChar then
      DelFlag := false
    else
      DelFlag := true;
    if ShowDeleted or (not DelFlag) or (RecNum > 0) then
      break;
  until false;
  GetRec := true;
  exit;
er:
  RecNumber := No_Record;
END;{/GetRec}

function TDBFFile.CheckFieldNum(AFldNum:TFldNum):boolean;
begin
  CheckFieldNum := false;
  if (AFldNum < 1) or (AFldNum > NumFields) then begin
    SetResult(trInvalidFieldNr, IntToStr(AFldNum));
    exit;
  end;
  CheckFieldNum := true;
end;

function TDBFFile.CheckFileStatus:boolean;
begin
  {CheckFileStatus := false;}
  if true{dFile.Status = stOK} then begin
    CheckFileStatus := true;
  end else begin
    {
    if dFile.Status = stReadError then begin
      SetResult(trReadBeyondEOF,'');  //Partial read only
    end else begin
      SetResult(dFile.Status,'Read File Error');
    end;
    }
  end;
end;

function TDBFFile.IsValidRecord:boolean;
begin
  IsValidRecord:= (RecNumber <> 0);
end;

function TDBFFile.CheckValidRecord:boolean;
begin
  CheckValidRecord:= false;
  if IsValidRecord then begin
    CheckValidRecord := true;
  end else begin
    SetResult(trNoRecLoaded, '');
  end;
end;

procedure TDBFFile.SaveRec;
begin
  if (RecNumber < 1) and (RecNumber <> New_Record) then begin
    SetResult(trReadBeyondEOF, 'In SaveRec');
    exit;
  end;
  PutRec(RecNumber);
end;

PROCEDURE TDBFFile.PutRec(RecNum : LongInt);
VAR
{   Result : Integer;}
   RNum   : LongInt;
BEGIN
  RNum := RecNum;
  IF (RNum > NumRecs) or (RNum < 1) then
  begin
     inc(NumRecs);
     RNum := NumRecs;
  end;
  dFile.Seek(HeadLen + (RNum-1) * RecLen,soFromBeginning);
  if CheckFileStatus then begin
    dFile.WriteBuffer(CurRecord^, RecLen);
    if CheckFileStatus then begin
      RecNumber := RNum;
      dStatus := stUpdated;
    end;
  end;
END;                        {PutRec}

PROCEDURE TDBFFile.Append;
BEGIN
  PutRec(0);
END;

PROCEDURE TDBFFile.Delete;
begin
  if CheckValidRecord then begin
    DelFlag := true;
    CurRecord^[0] := DeleteChar;
    PutRec(RecNumber);
  end;
end;

PROCEDURE TDBFFile.UnDelete;
begin
  if CheckValidRecord then begin
    DelFlag := false;
    CurRecord^[0] := UnDeleteChar;
    PutRec(RecNumber);
  end;
end;

PROCEDURE TDBFFile.Close;

CONST
   EofMark : Byte = $1A;

var
   yy, mm, dd{, wd} : word;

  procedure UpDate_File;
  BEGIN
    {GetDate (yy,mm,dd,wd);}
    DecodeDate(SysUtils.Now, yy, mm, dd);
    Head.year := yy - 1900; {Year}
    Head.month := mm; {Month}
    Head.day := dd; {Day}
    Head.RecCount := NumRecs;
    dbfError := 0;
    try
      dFile.Seek(0, soFromBeginning);
      dFile.WriteBuffer(Head, 8);
      dFile.Seek(HeadLen + NumRecs*RecLen, soFromBeginning);
      dFile.WriteBuffer(EofMark, 1);{Put EOF marker }
    except
      dbfError := -1;{dFile.Status;}
    end;
  END;   { IF Updated }

begin
  dbfError := 0;
  IF dStatus = stNotOpen THEN
    exit;
  IF dStatus = stUpdated THEN
    UpDate_File;
    
  ClassFree(dFile);
  IF dbfError = 0 THEN
  BEGIN
    if WithMemo then
      System.Close(mFile);
    dbfError := IOResult;
    dStatus := stNotOpen;
  END;
END;                        { GS_dBase_Close }

procedure TDBFFile.StreamOpen;
begin
  if dFile = nil then
  try
    dFile := TFileStream.Create(FileName, fmOpenReadWrite + fmShareDenyWrite);
    dbfError := 0;
    dStatus := stNotUpdated;
  except
    dStatus := stNotOpen;
    dbfError := -1;{dFile.Status;}
  end;
end;

procedure TDBFFile.StreamClose;
begin
  ClassFree(dFile);
  dStatus := stNotOpen;
end;

PROCEDURE TDBFFile.Open;
BEGIN
  if dStatus = stNotOpen then
  begin
    StreamOpen;
    if WithMemo then
      Reset(mFile,512);
    RecNumber := 0;
  end;
END;                        { GS_dBase_Open }

constructor TDBFFile.Create(FName : string);
{var
  i: integer;}

  procedure ProcessHeader;
  {VAR
    Res: integer;}
    {o, i: Integer;}
    {m, dy, y: string[2];}
  begin
    CASE Head.DBFType OF
      DB3File : WithMemo := False;
      DB3WithMemo : WithMemo := True;
    ELSE
      dbfError := 157;  {Not dBase file (Unknown Media)}
      raise EDBF.Create('Not dBase file');
    END;

    With Head do
      DateOfUpdate := GetDateString(month, day, year);
    NumRecs := Head.RecCount;
    HeadLen := Head.Location;
    RecLen := Head.RecordLen;
    RecNumber := 0;
    {Fields:= MemAlloc(HeadLen-33); { Allocate memory for a buffer  }
    GetMem(Fields, HeadLen - 33);
    NumFields := (HeadLen - 33) div 32;
    dFile.ReadBuffer(Fields^, HeadLen-33);
    UpdateFieldDef;
  end;                      {ProcessHeader}

  PROCEDURE GetHeader;
  BEGIN                     { GetHeader }
    try
      dFile.ReadBuffer(Head, 32);
      dbfError := 0;
    except
      dbfError := -1;{dFile.status;}
      raise;
    end;
    ProcessHeader;
  END;

begin
  inherited Create;
  FileName := ReplaceExt(FName, DBFExt, false);
  dFile := nil;
  dStatus := stNotOpen;
  dbfError := 0;
  CurNumFields := 0;
  CurFieldAddress := 0;
  Fields := nil;
  CurRecord := nil;

  StreamOpen;
  try
    GetHeader;
  finally
    StreamClose;
  end;
  GetMem(CurRecord, RecLen); { Allocate memory for a buffer  }
  FillChar(CurRecord^, RecLen, '#');
  if WithMemo then
    AssignFile(mFile, FName+'.DBT');
end;

destructor TDBFFile.Destroy;
begin
  Close;
  if Fields <> nil then begin
    FreeMem(Fields,HeadLen-33);
  end;
  if CurRecord <> nil then
    FreeMem(CurRecord, RecLen);
  SelDone;
  inherited Destroy;
end;

procedure TDBFFile.CreateFile(const FName: TFileName);
begin
  FileName := ReplaceExt(FName, DBFExt, false); {add dbf extension if none present}
  try
    dFile := TFileStream.Create(FileName, fmOpenReadWrite+fmShareDenyWrite);{create new DBF file}
    dbfError := 0;
  except
    dbfError := -1;{dfile.status;}
    raise;
  end;
end;

function TDBFFile.GetDateString(mm,dd,yy:word):String8;
var   m,dy,y : string[2];
begin
  Str(mm,m);
  if length(m) = 1 then m := '0'+m;
  Str(dd,dy);
  if length(dy) = 1 then dy := '0'+dy;
  Str(yy,y);
  if length(y) = 1 then y := '0'+y;
  GetDateString:= m + '/' + dy + '/' + y;
end;

procedure TDBFFile.MakeHeader;
VAR
  yy, mm, dd{, wd} : word;
  i, rl          : integer;
begin
  Head.DBFType := DB3File;
  DecodeDate(SysUtils.Now, yy, mm, dd);
  yy := yy - 1900;
  Head.year := yy;
  Head.month := mm;
  Head.day := dd;
  Head.RecCount := 0;
  Head.Location := (NumFields*32) + 33;
  rl := 1;
  for i := 1 to NumFields do
    rl := rl + Fields^[i].L;
  Head.RecordLen := rl;
  FillChar(Head.Reserved,20,#0);
  try
    dFile.Seek(0, soFromBeginning);
    dFile.WriteBuffer(Head, 32);
    dFile.WriteBuffer(Fields^, NumFields*32);
    dFile.WriteBuffer(EohMark, 1);  {Put EOH marker }
    dFile.WriteBuffer(EofMark, 1); {Put EOF marker }
    dbfError := 0;
  except
    dbfError := -1;{dFile.status;}
  end;

  DateOfUpdate := GetDateString(mm,dd,yy);
  HeadLen := Head.Location;
  RecLen := rl;
  NumRecs := 0;
  RecNumber := 0;
end;

procedure TDBFFile.CreateDone;
begin
  if dbfError <> 0 then
    exit;
  MakeHeader;
  {dbfError := 0;{dFile.Status;}
  dFile.Free;
  dFile := nil;
  if dbfError = 0 then begin
    GetMem(CurRecord, RecLen); { Allocate memory for a buffer  }
    if CurRecord = nil then
      dbfError := erNotEnoughMemory;
  end;
end;

constructor TDBFFile.CreateCopy(FName, Template: string); {create file FName with structure of .dbf file Template}
var
  db: TDBFFile;
  AFields: PDBFFields;
begin
  inherited Create;
  db := TDBFFile.Create(Template);
  try
    GetMem (AFields, db.NumFields * 32);
    move(db.Fields^, AFields^, db.NumFields * 32);
    CreateIndirect(FName, AFields, db.NumFields,  false);
  finally
    db.Free;
  end;
end;

constructor TDBFFile.CreateIndirect(FName : string; AFields: PDBFFields;
                             FCnt : integer; AllocateCopy:boolean);
begin
  inherited Create;
  CreateFile(FName);
  NumFields := FCnt;
  CurNumFields := FCnt;
  if AllocateCopy then begin
    GetMem (Fields, FCnt * 32);
    move(AFields^, Fields^, FCnt * 32);
  end else begin
    Fields := AFields;
  end;
  CreateDone;
  dStatus := stNotOpen;
END;

procedure TDBFFile.UpdateFieldDef;
begin
  CurNumFields := 0;
  CurFieldAddress := 1;
  repeat
    inc(CurNumFields);
    if CurNumFields > NumFields then
      exit;
    with Fields^[CurNumFields] do begin
      A := CurFieldAddress;
      inc(CurFieldAddress, L);
    end;
  until false;
  if RecLen = 0 then
    RecLen := CurFieldAddress;
end;

procedure TDBFFile.CreateField(AFieldName: string10; AFieldType: Char;
                            AFieldLen: Byte; AFieldDec: Byte);
begin
  if dbfError <> 0 then
    exit;
  inc(CurNumFields);
  if CurNumFields > NumFields then
    exit;
  with Fields^[CurNumFields] do begin
    StrPCopy(N, AFieldName);
    T := AFieldType;
    L := AFieldLen;
    D := AFieldDec;
    A := CurFieldAddress;
  end;
  inc(CurFieldAddress, AFieldLen);
end;

constructor TDBFFile.Create(FName : string; FCnt : integer);
begin
   inherited Create;
   CreateFile(FName);
   if dbfError <> 0 then
     Fail;
   GetMem (Fields, FCnt * 32);
   NumFields := FCnt;
   CurNumFields := 0;
   CurFieldAddress := 1;
   if Fields = nil then begin
     Fail;
   end;
end;

function TDBFFile.UsedRecs:longint;
begin
  if not FScanned then begin
    FUsedRecs := 0;
    if GetRec(Top_Record) then
    repeat
      inc(FUsedRecs);
    until not GetRec(Next_Record);
  end;
  UsedRecs := FUsedRecs;
end;

function TDBFFile.BrowseInit(const ADefName:string): TTblResult;
var
  s: string;
  i: integer;
begin
  s := '';
  for i := 1 to NumFields do begin
    s := s + ' ' + Pad(StrPas(Fields^[i].N), Fields^[i].L);
  end;
  BrowseHeader := s;
  BrowseInit := trOK;
end;

procedure TDBFFile.BrowseDone;
begin
end;

function TDBFFile.BrowseLine: string;
var
  s:string;
  i:integer;
begin
  s :='';
  if RecNumber > 0 then begin
    for i := 1 to NumFields do begin
      s := s + ' ' + GetFieldValue(i);
    end;
  end;
  BrowseLine := s;
end;

{$IFDEF SELECT}
function TDBFFile.SelInit: boolean;
begin
  SelInit := false;
  if SelInfo = nil then begin
    SelInfo := TSelInfo.Create(Self);
    if SelInfo = nil then
      exit;
  end;
  SelInit := true;
end;

procedure TDBFFile.SelDone;
begin
  ClassFree(SelInfo);
end;

procedure TDBFFile.RecordSelect(OnOff:boolean);
begin
  if not SelInit then
    exit;
  SelInfo.Select(OnOff);
end;

function TDBFFile.RecordSelected:boolean;
begin
  if not SelInit then begin
    RecordSelected := false;
  end else begin
    RecordSelected := SelInfo.Selected;
  end;
end;
{$ENDIF SELECT}

{/TDBFFile}

{$IFDEF SELECT}

{TSelInfo}
constructor TSelInfo.Create(ADBFFile: TDBFFile);
begin
  inherited Create;
  DBF := ADBFFile;
  SelFldNr := DBF.GetFieldNum('SELECTED');
end;

destructor TSelInfo.Destroy;
begin
  inherited Destroy;
end;

function TSelInfo.Selected: boolean;
begin
  Selected := false;
  if SelFldNr > 0 then begin
    Selected := boolean(round(DBF.GetFieldNumValue(SelFldNr)));
  end;
end;

procedure TSelInfo.Select(OnOff:boolean);
begin
  if SelFldNr > 0 then begin
    DBF.PutFieldNumValue(SelFldNr, byte(OnOff));
  end;
end;

{/TSelInfo}
{$ENDIF SELECT}

(*
PROCEDURE TDBFFile.PACK;
CONST
   EofMark : Byte = $1A;
   EohMark : Byte = $0D;
   ZroMark : Byte = $00;

var
   df : TBufStream;
   tmp:pathstr;
   Procedure Copy_Recs;
   var
      i, j : longint;
   begin
      j := 0;
      for i := 1 to NumRecs do
      begin
         GetRec(i);
         if not DelFlag then
         begin
           {$I-} df.write( CurRecord^, RecLen); {$I+}
           dbfError := df.status;
           inc(j);
         end;
      end;
      NumRecs := j;
      df.write( EofMark, 1);{Put EOF marker }
      dbfError := df.status;
   end;

   Procedure Copy_Head;
   var
      delta : integer;
   begin
      df.seek( 0);
      dbfError := df.status;
      IF dbfError = 0 THEN
      BEGIN
         {$I-} df.write( Head, 32); {$I+}
         dbfError := df.status;
      END;
      IF dbfError = 0 THEN
      BEGIN
         {$I-} df.write( Fields^, NumFields*32); {$I+}
         dbfError := df.status;
      END;
      IF dbfError = 0 THEN
      BEGIN
         {$I-} df.write( EohMark, 1); {$I+} {Put EOH marker }
         dbfError := df.status;
      END;
      delta := (NumFields*32) + 33;
      while delta <> Head.Location do
      begin
         df.write( ZroMark, 1);{Put Zero }
         inc(delta);
      end;

   end;

begin
  if dbfError<>0 then exit;
   tmp:='DB$$$.DB$';
   df.init(tmp,stCreate, StreamBufferSize);
   dbfError := df.status;

   if dbfError = 0 then
   begin
      Copy_Head;
      Copy_Recs;
   end;
   dStatus := stUpDated;
   dFile.done;
   df.done;
   EraseFile(FileName);
   RenameFile(tmp, Filename);
   dFile.Init(FileName, stOpen, StreamBufferSize);
   Close;
   Open;
END;                        { GS_dBase_Pack }
*)

function IsValid(ADBF:pointer):boolean;
begin
  if ADBF = nil then begin
    GSetResult(trInvalidTblHandle, '');
    IsValid := false;
  end else begin
    IsValid := true;
  end;
end;

function DBFCreate(const AFileName: TFileName; AFields:PDBFFields; AFieldCount:integer):TTblResult;
var d:TDBFFile;
begin
  GClearResult;
  try
    d := TDBFFile.CreateIndirect(AFileName, AFields, AFieldCount, true);
    ClassFree(d);
  except
    GSetResult(trCreateTblFileFailed, AFileName);
  end;
  DBFCreate := GLastResult;
end;

function DBFInit(const AFileName: TFileName; var ADBF:pointer):TTblResult;
begin
  GClearResult;
  try
    ADBF := TDBFFile.Create(AFileName);
    TDBFFile(ADBF).Open;
  except
    GSetResult(trInitFailed, AFileName);
  end;
  DBFInit := GLastResult;
end;

function DBFFirst(ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetRec(Top_Record);
  end;
  DBFFirst := GLastResult;
end;

function DBFNext(ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetRec(Next_Record);
  end;
  DBFNext := GLastResult;
end;

function DBFLast(ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetRec(Bottom_Record);
  end;
  DBFLast := GLastResult;
end;

function DBFPrior(ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetRec(Prev_Record);
  end;
  DBFPrior := GLastResult;
end;

function DBFPost(ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).SaveRec;
  end;
  DBFPost := GLastResult;
end;

function DBFGetFld(ADBF:pointer; AFieldName:TFldName):TFldNum;
var i: TFldNum;
begin
  i := 0;
  if IsValid(ADBF) then begin
    i := TDBFFile(ADBF).GetFieldNum(AFieldName);
  end;
  DBFGetFld := i;
end;

function DBFGetStr(ADBF:pointer; J:TFldNum):TFldStrVal;
var s: TFldStrVal;
begin
  s := '';
  if IsValid(ADBF) then begin
    s := TDBFFile(ADBF).GetFieldValue(J);
  end;
  DBFGetStr := s;
end;

function DBFGetNum(ADBF:pointer; J:TFldNum):TFldNumVal;
var n: TFldNumVal;
begin
  n := 0;
  if IsValid(ADBF) then begin
    n := TDBFFile(ADBF).GetFieldNumValue(J);
  end;
  DBFGetNum := n;
end;

function DBFGetInt(ADBF:pointer; J:TFldNum):TFldIntVal;
begin
  DBFGetInt := round(DBFGetNum(ADBF, J));
end;

function DBFSetStr(ADBF:pointer; J:TFldNum; AValue:TFldStrVal):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).PutFieldValue(J, AValue);
  end;
  DBFSetStr := GLastResult;
end;

function DBFSetNum(ADBF:pointer; J:TFldNum; AValue:TFldNumVal):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).PutFieldNumValue(J, AValue);
  end;
  DBFSetNum := GLastResult;
end;

function DBFSetInt(ADBF:pointer; J:TFldNum; AValue:TFldIntVal):TTblResult;
begin
  DBFSetInt := DBFSetNum(ADBF, J, AValue);
end;

function DBFGetProp(ADBF:pointer; tp:TTblProperty; APValue:pointer; ASize:TBufSize):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then
    TDBFFile(ADBF).GetProp(tp, APValue, ASize);
  DBFGetProp := GLastResult;
end;

function DBFSetProp(ADBF:pointer; tp:TTblProperty; APValue:pointer; ASize:TBufSize):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then
    TDBFFile(ADBF).SetProp(tp, APValue, ASize);
  DBFSetProp := GLastResult;
end;

function DBFGetPropInt(ADBF:pointer; tp:TTblProperty):longint;
var l:longint;
begin
  l := 0;
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetProp(tp, @l, sizeof(l));
  end;
  DBFGetPropInt := l;
end;

function DBFSetPropInt(ADBF: pointer; tp: TTblProperty; AValue: longint): TTblResult;
begin
  if IsValid(ADBF) then
    TDBFFile(ADBF).SetProp(tp, @AValue, sizeof(AValue));
  DBFSetPropInt := GLastResult;
end;

function DBFGetPropStr(ADBF:pointer; tp:TTblProperty):string;
var s: string;
begin
  s := '';
  if IsValid(ADBF) then begin
    TDBFFile(ADBF).GetProp(tp, @s, sizeof(s));
  end;
  DBFGetPropStr := s;
end;

function DBFDone(var ADBF:pointer):TTblResult;
begin
  GClearResult;
  if IsValid(ADBF) then begin
    ClassFree(ADBF);
    ADBF := nil;
  end;
  DBFDone := GLastResult;
end;

{v1.01}
function DBFScan(const AFileName: TFileName;
  ATblScanOptions: PTblScanOptions; ACallBack:PTblEventHandler):TTblResult;
var
  t: PDBF;
  d, r: TTblResult;
  ba, a: TTblAlias;
  cb: TTblEventHandler;
  pb: TProgressBox;
  cnt, allcnt:longint;
  tso: TTblScanOptions;
label
  ex;
begin
  a := '';
  ba := '';
  fillchar(tso, sizeof(tso), 0);
  if ATblScanOptions <> nil then
    tso := ATblScanOptions^;
  if tso.BaseAlias <> '' then begin
    a := tso.BaseAlias + asRead;
    ba := tso.BaseAlias;
  end;
  if Assigned(ACallBack) then
    @cb := ACallBack
  else
    cb := nil;
  pb := nil;
  cnt := 0;
  r := DBFInit(AFileName, t);
  if r <> trOK then
    goto ex;
  allcnt := DBFGetPropInt(t, tpRecordCount);
  {if tso.IndexName <> '' then begin
    r := TblSetPropStr(t, tpIndexName, tso.IndexName);
    if r <> trOK then
      goto ex;
  end;}
  if DBFFirst(t) = trOK then
  begin
    if tso.ShowProgress then
      ProgressBox(pb, pbShow, AFileName, 0, 0);
    repeat
      if Assigned(ACallBack) then begin
        cb(t);
        r := DBFGetPropInt(t, tpLastResult);{dbu}
        if r <> trOK then
          break;
        inc(cnt);
        if cnt = 140 then begin
          cnt := 140;
        end;
        if pb <> nil then
          ProgressBox(pb, pbUpdate, '', cnt, allcnt);
      end;
    until DBFNext(t) <> trOK;
    if pb <> nil then
      ProgressBox(pb, pbHide, '', 0, 0);
  end;
ex:
  d := DBFDone(t);
  if r = trOK then
    r := d;
  DBFScan := r;
end;

(*
function GetMonthlyFileName(const AFileName:string; const Date:PDTO): string;
var
  d:dirstr;
  n:namestr;
  e:extstr;
  yyyymm:namestr;
begin{DataDir[\CCYYMM]\fnYYMM.ext}
  FSplit(AFileName, d, n, e);
  yyyymm := copy(d, length(d) - 6, 6);
  if d = '' then
    d := USUppcase(DataDir);
  if StrToInt(yyyymm) = 0 then begin
    if DTGet(Date, dtIsValid) = dtOK then begin
      d := d + DTGetStr(Date, dtYYYYMM) + '\';
    end;
  end else begin
    if yyyymm <> DTGetStr(Date, dtYYYYMM) then begin
      d := copy(d, 1, length(d) - 7);
      if DTGet(Date, dtIsValid) = dtOK then
        d :=  d + DTGetStr(Date, dtYYYYMM) + '\'
    end;
  end;
  if (DTGet(Date, dtIsValid) = dtOK) then begin
    {if (DTGetStr(Date, dtYYYYMM) >= DTGetStr(DTNow, dtYYYYMM)) then}
    DirDo(daDirCreate, d);
    if true{ShouldIncludeValidDateToName} then
      n := copy(n,1,4) + DTGetStr(Date, dtYYMM);
  end else begin
    if length(n) > 4 then
      n := copy(n, 1, length(n) - 4);
  end;
  GetMonthlyFileName := ReplaceFileNamePart(fpExt, d + n + e, DBFExt, false);
end;

function DBFsScan(const ABaseFileName: string;
  var AFromMonth: TDateString; var AToMonth: TDateString;
  ATblScanOptions:PTblScanOptions; ACallBack: PTblEventsHandler): TTblResult;
  { scan monthly tables with ABaseFileName (should include dir) in the period
    AFromMonth - AToMonth. If AFromMonth = '' then from the first existing
    table will be scanned, if AToMonth = '' then to the last existing
    table (most probably this month). In these cases (empty AFromMonth
    or AToMonth)  these variables will be set to the found values.
    See dbtype.TTblScanOptions for possible options. Using nil for
    ATblScanOptions defaults will be used. If ACallBack non nil, then
    this procedure will be called for each valid record from all
    tables. }
var
  dt, dt2: PDTO;
  fn: string;
  t: PDBF;
  pb: TProgressBox;
  tso: TTblScanOptions;
  si: word;
  r: TTblResult;
  capt: string;
  cb: TTblEventsHandler;
  cnt, allcnt:longint;
label ex;
begin
  pb := nil;
  t := nil;
  dt := DTInit;
  dt2 := DTInit;
  fillchar(tso, sizeof(tso), 0);
  r := 0;
  if ATblScanOptions <> nil then begin
    si := ATblScanOptions^.Size;
    if (si > 0) and (si < sizeof(tso)) then
      move(ATblScanOptions^, tso, si)
    else
      tso := ATblScanOptions^;
  end;
  if ACallBack <> nil then
    @cb := ACallBack;

  if AFromMonth = '' then begin
    DTAssign(dt, DTNow);
    repeat
      fn := GetMonthlyFileName(ABaseFileName, dt);
      if not FExists(fn) then
        break;
      DTDo(dt, dtIncMonth, -1);
    until false;
    DTDo(dt, dtIncMonth, 1);
    AFromMonth := copy(DTGetStr(dt, dtDateString), 1, 6);
  end else begin
    DTSetStr(dt, dtDateString, AFromMonth);
  end;
  DTSetStr(dt, dtDateString, AFromMonth);
  DTSet(dt, dtDay, 1);
  if DTGet(dt, dtIsValid) <> dtOK then begin
    r := -1;
    SysError('DBFsScan invalid AFromMonth: ' + DTGetStr(dt, dtDateString));
    goto ex;
  end;

  if AToMonth = '' then begin
    DTAssign(dt2, DTNow);
    AToMonth := copy(DTGetStr(dt2, dtDateString), 1, 6);
  end else begin
    DTSetStr(dt2, dtDateString, AToMonth);
  end;
  DTSet(dt2, dtDay, 1);
  if DTGet(dt2, dtIsValid) <> dtOK then begin
    r := -1;
    SysError('DBFsScan invalid AToMonth: ' + DTGetStr(dt2, dtDateString));
    goto ex;
  end;

  if tso.ShowProgress then begin
    if tso.ProgressCaption <> '' then
      capt := tso.ProgressCaption
    else
      capt := 'Scanning ' + ABaseFileName;
    ProgressBox(pb, pbShow, capt, 0,0);
  end;

  while DTGetStr(dt, dtYYYYMM) <= AToMonth do begin
    fn := GetMonthlyFileName(ABaseFileName, dt);
    if FExists(fn) then begin
      if pb <> nil then
        ProgressBox(pb, pbMsg, fn, 0, 0);
      r := DBFInit(fn, t);
      if r <> trOK then
        goto ex;
      if ACallBack <> nil then
        cb(teAfterOpen, t);
      r := DBFFirst(t);
      if r <> trOK then
        goto ex;
      cnt := 0;
      allcnt := DBFGetPropInt(t, tpRecordCount);
      repeat
        if ACallBack <> nil then begin
          cb(teOnCalcFields, t);
          r := DBFGetPropInt(t, tpLastResult);
          if r <> trOK then
            goto ex;
        end;
        inc(cnt);
        if pb <> nil then
          ProgressBox(pb, pbUpdate, '', cnt, allcnt);
      until DBFNext(t) <> trOK;
      DBFDone(t);
    end;
    DTDo(dt, dtIncMonth, 1);
  end;
ex:
  if t <> nil then
    DBFDone(t);
  DTDone(dt);
  DTDone(dt2);
  if pb <> nil then
    ProgressBox(pb, pbHide, '',0,0);
  DBFsScan := r;
end;
*)
function DBFGetFldStr(ADBF: pointer; const AFieldName:TFldName): string;
var
  n: TFldNum;
  s: string;
begin
  s := '';
  n := DBFGetFld(ADBF, AFieldName);
  if n <> 0 then
    s := DBFGetStr(ADBF, n);
  DBFGetFldStr := s;
end;

function DBFSetFldStr(ADBF: pointer; const AFieldName: TFldName; const AValue: string): TTblResult;
var
  n: TFldNum;
begin
  n := DBFGetFld(ADBF, AFieldName);
  if n <> 0 then begin
    DBFSetFldStr := DBFSetStr(ADBF, n, AValue);
  end else begin
    DBFSetFldStr := trInvalidFieldName;{dbtype}
  end;
end;

function DBFAppend(ADBF: pointer): TTblResult;
begin
  TDBFFile(ADBF).NewRec;
  DBFAppend := 0;
end;

function DBFZap(ADBF: Pointer): TTblResult;
begin
  TDBFFile(ADBF).Truncate(0);
  DBFZap := TDBFFile(ADBF).dbfError;
end;

function DBFGetFldInt(ADBF: pointer; const AFieldName:TFldName): TFldIntVal;
var
  v: TFldIntVal;
  code: integer;
begin
  val(trim(DBFGetFldStr(ADBF, AFieldName)), v, code);
  DBFGetFldInt := v;
end;

function DBFGetFldNum(ADBF: pointer; const AFieldName:TFldName): TFldNumVal;
var
  v: TFldNumVal;
  code: integer;
begin
  val(trim(DBFGetFldStr(ADBF, AFieldName)), v, code);
  DBFGetFldNum := v;
end;

function DBFSetFldInt(ADBF: pointer; const AFieldName: TFldName; const AValue: TFldIntVal): TTblResult;
begin
  DBFSetFldInt := DBFSetFldStr(ADBF, AFieldName, IntToStr(AValue));
end;

function DBFSetFldNum(ADBF: pointer; const AFieldName: TFldName; const AValue: TFldNumVal): TTblResult;
var s: string;
begin
  str(AValue, s);
  DBFSetFldNum := DBFSetFldStr(ADBF, AFieldName, s);
end;

{DBFInterface}
(*
function DBFDataInit(const FName: string; const DefName: string;
    const Alias: string; Options: longint; var Data:pointer): TDataResult;
var
  n:string;
begin
  n := ReplaceFileNamePart(fpExt, FName, '.DBF', false);
  if FExists(n) then begin
    DBFDataInit := DBFInit(FName, Data);
  end else begin
    n := ReplaceFileNamePart(fpExt, DefName, '.DBF', false);
    Data := New(TDBFFile, CreateCopy(FName, n));
    if Data = nil then
      DBFDataInit := trInitFailed{dbtype}
    else
      DBFDataInit := 0;
  end;
end;

function DBFGetRec(DataSrc: pointer; ARef: longint; var Buf; EvenLockedRec:boolean): TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if GetRec(ARef) then begin
      move(CurRecord^, Buf, RecLen);
    end;
    DBFGetRec := GLastResult;
  end;
end;

function DBFNextRecRef(DataSrc: pointer; var ARef: longint): TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if (not GetRec(ARef + 1)) and (GLastResult <> trEOF)
      and (GLastResult <> trReadBeyondEOF)
    then
      GetRec(Next_Record);
    ARef := RecNumber;
    DBFNextRecRef := GLastResult;
  end;
end;

function DBFPrevRecRef(DataSrc: pointer; var ARef: longint): TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if (not GetRec(ARef - 1)) and (GLastResult <> trBOF) then
      GetRec(Prev_Record);
    ARef := RecNumber;
    DBFPrevRecRef := GLastResult;
  end;
end;

function DBFFindRecRef(DataSrc:pointer; var Ref: longint; NSFD: integer): TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if (not GetRec(Ref)) or DelFlag then begin
      if NSFD < 0 then begin
        GetRec(Prev_Record);
      end else if NSFD > 0 then begin
        GetRec(Next_Record);
      end;
    end;
    Ref := RecNumber;
    DBFFindRecRef := GLastResult;
  end;
end;

function DBFIsReadLocked(DataSrc:pointer):boolean;
begin
  DBFIsReadLocked := false;
end;

function DBFIsLocked(DataSrc:pointer):boolean;
begin
  DBFIsLocked := false;
end;

function DBFIsNetFile(DataSrc:pointer):boolean;
begin
  DBFIsNetFile := false;
end;

function DBFReadLock(DataSrc: pointer):TDataResult;
begin
  DBFReadLock := 0;
end;

function DBFUnLock(DataSrc: pointer):TDataResult;
begin
  DBFUnLock := 0;
end;

function DBFGetApprRecRef(DataSrc:pointer; RelPos, Scale:word; var UserDatRef:longint):TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if Scale > 0 then
      UserDatRef := NumRecs * RelPos div Scale
    else
      UserDatRef := 0;
    DBFGetApprRecRef  := 0;
  end;
end;

function DBFGetApprRecPos(DataSrc:pointer; var RelPos: word; Scale:word; UserDatRef:longint):TDataResult;
begin
  with TDBFFile(DataSrc)^ do begin
    if NumRecs > 0 then
      RelPos := word(longint(Scale) * UserDatRef div NumRecs)
    else
      RelPos := 0;
    DBFGetApprRecPos  := 0;
  end;
end;

function DBFUsedRecs(DataSrc: pointer):longint;
begin
  DBFUsedRecs := TDBFFile(DataSrc)^.UsedRecs;
end;

function DBFLastErrorClass(DataSrc: pointer): TErrorClass;
begin
  case GLastResult of
    trReadBeyondEOF,trBOF, trEOF: DBFLastErrorClass := 1;


  else
    DBFLastErrorClass := GLastResult;{!!!}
  end;
end;

procedure DBFClearResult; { IsamClearOK }
begin
  GClearResult;
end;

function DBFBrowseInit(DataSrc: pointer; const ADefName: string): TDataResult;
  { initialize data needed for browsing }
begin
  with TDBFFile(DataSrc)^ do begin
    DBFBrowseInit := BrowseInit(ADefName);
  end;
end;

function DBFBrowseDone(DataSrc: Pointer): TDataResult;
begin
  DBFBrowseDone := 0;
  TDBFFile(DataSrc)^.BrowseDone;
end;

function DBFBrowseHead(DataSrc: pointer): string;
begin
  DBFBrowseHead := GetString(TDBFFile(DataSrc)^.BrowseHeader);
end;

function DBFBrowseLine(DataSrc: pointer): string;
begin
  DBFBrowseLine := TDBFFile(DataSrc)^.BrowseLine;
end;

function DBFGetRecBuf(DataSrc: pointer): pointer;
begin
  DBFGetRecBuf := TDBFFile(DataSrc)^.CurRecord;
end;
*)
{/DBFInterface}
begin
  (*
  with DBFInterface do begin
    DataInit := DBFDataInit;
    DataDone := DBFDone;
    GetRec := DBFGetRec; { BTGetRec ( UsedFileBlock, RR.Ref, DataBuffer^, False ); IsamError }
    NextRecRef:= DBFNextRecRef; { BTNextRecRef ( UsedFileBlock, Ref ); IsamError }
    PrevRecRef:= DBFPrevRecRef;{ BTPrevRecRef ( UsedFileBlock, Ref ); }
    FindRecRef:= DBFFindRecRef; {BTFindRecRef ( UsedFileBlock, Ref, NFSD );}
    IsReadLocked:= DBFIsReadLocked;    {BTFileBlockIsReadLocked ( UsedFileBlock )}
    IsLocked:= DBFIsLocked;        {Or BTFileBlockIsLocked ( UsedFileBlock );}
    IsNetFile:= DBFIsNetFile;       { BTPeekIsNetFileBlock ( UsedFileBlock );}
    ReadLock:= DBFReadLock;       { BTReadLockFileBlock }
    UnLock:= DBFUnLock;         { BTUnLockFileBlock ( UsedFileBlock );}
    GetApprRecRef:= DBFGetApprRecRef; { BTGetApprRecRef ( UsedFileBlock, RelPos, Scale, UserDatRef );}
    GetApprRecPos:= DBFGetApprRecPos; { BTGetApprRecPos ( UsedFileBlock, RelPos, Scale, UserDatRef );}
    UsedRecs:= DBFUsedRecs;  {BTUsedRecs ( UsedFileBlock );}
    LastErrorClass:= DBFLastErrorClass;{ BTIsamErrorClass }
    ClearResult:= DBFClearResult; { IsamClearOK }
    GetRecBuf:= DBFGetRecBuf;
    BrowseInit:= DBFBrowseInit; { initialize data needed for browsing }
    BrowseDone:= DBFBrowseDone;
    BrowseHead:= DBFBrowseHead;
    BrowseLine:= DBFBrowseLine;
    GetPropInt:= DBFGetPropInt;
    SetPropInt:= DBFSetPropInt;
    {BrowseBuildRow}
    {datatype}
  end;
  *)
end.
