dbf.pas

很管用的GIS控件

    property BeforeScroll;
    property AfterScroll;
    property OnCalcFields;
    property OnDeleteError;
    property OnEditError;
    property OnFilterRecord;
    property OnNewRecord;
    property OnPostError;

//my datas....
  protected
    _IsCursorOpen:boolean;
    _PhysicalRecno:integer;
		_CurIndex: TIndex;
		_Indexes:TList;      // index
		_indexFile : TIndexFile;
		_dbtFile : TDbtFile;
	public
		_dbfFile:TDbfFile;
		property PhysicalRecno:integer read _PhysicalRecno;
		function _RecordDataSize:integer;
	end;

procedure Register;

var
	tDbf_TrimFields : boolean;

implementation

var
		_PagedFiles : TList;

//====================================================================
// Some types and consts which are not useful in the interface.
//====================================================================
(*
 * tSmallint  16 bits = -32768 to 32767
 *                      123456 = 6 digit max
 * ftInteger  32 bits = -2147483648 to 2147483647
 *                      12345678901 = 11 digits max
 * ftLargeInt 64 bits = -9223372036854775808 to 9223372036854775807
 *                      12345678901234567890 = 20 digits max
 *)
const
  DIGITS_SMALLINT = 6;
  DIGITS_INTEGER = 11;
  DIGITS_LARGEINT = 20;
  sDBF_DEC_SEP= '.';

type
  rAfterHdrIII = record // Empty
  end;

  rAfterHdrV = record
    Dummy   : array[32..67] of byte;
  end;

  PMdxTag = ^rMdxTag;

  rMdxTagHdr = record
    RootPage        : longint;// 0..3
    FilePages        : longint;// 4..7
    KeyFormat        : byte;   // 8
    KeyType          : char;   // 9
    dummy            : word;   // 10..11
    IndexKeyLength   : word;   // 12..13
    MaxNbKeys       : word;   // 14..15
    SecondKeyType   : word;   // 16..17
    IndexKeyItemLen  : word;   // 18..19
    dummy2           : array [20..22] of byte;
    UniqueFlag      : byte;   // 23
  end;


  rAfterHdrV3 = record
    Dummy   : array[12..31] of byte;
  end;

  rAfterHdrV4 = record
    Dummy   : array[12..67] of byte;
  end;

  rFieldHdrV3 = record
    FieldName   : array[0..10] of char;
    FieldType   : char; // 11
    Dummy        : array[12..15] of byte;
    FieldSize   : byte; // 16
    FieldPrecision  : byte; //17
    dummy2      : array[18..31] of byte;
  end;

  rFieldHdrV4 = record
    FieldName   : array[0..10] of char;
    Dummy0        : array[11..31] of byte;
    FieldType   : char; // 32
    FieldSize   : byte; // 33
    FieldPrecision  : byte; //34
    dummy2      : array[35..47] of byte;
  end;
  PDouble = ^double;
//====================================================================
// Now some common functions and procedure
//====================================================================
// ****************************************************************************
// International separator
// thanks to Bruno Depero from Italy
// and Andreas W鰈lenstein from Denmark

function DbfStrToFloat(s: string): Extended;
var iPos: integer;
     eValue: extended;
begin
    iPos:= Pos(sDBF_DEC_SEP, s);
    if iPos> 0 then
      s[iPos]:= DecimalSeparator;
    if TextToFloat(pchar(s), eValue, fvExtended) then
      Result:= eValue
    else Result:= 0;
end;

function FloatToDbfStr(f: Extended; size, prec: integer): string;
var iPos: integer;
begin
    Result:= FloatToStrF(f, ffFixed, Size, prec);
    iPos:= Pos(DecimalSeparator, Result);
    if iPos> 0 then
      Result[iPos]:= sDBF_DEC_SEP;
end;

procedure MyMove(Source, Dest:PChar; Count: Integer);
var
  c:char;
  i:integer;
begin
  i:=0;
  while i<Count do begin
    c:=PChar(Source)[i];
    if c=#0 then break;
    PChar(Dest)[i]:=c;
    Inc(i);
  end;
  while i<Count do begin
    PChar(Dest)[i]:=' ';
    Inc(i);
  end;
end;
//====================================================================
// TPagedFile
//====================================================================
function GetPagedFile(FileName: string):TPagedFile;
var
  idx:integer;
  idf:TPagedFile;
begin
  FileName:=LowerCase(FileName);
  for idx:=0 to _PagedFiles.Count-1 do begin
    idf:= TPagedFile(_PagedFiles[idx]);
    if idf._FileName=FileName then begin
      result:=idf;
      exit;
    end;
  end;
  result:=nil;
end;

procedure TPagedFile.Release;
begin
  dec(_cntuse);
  if _cntuse<=0 then begin
    _PagedFiles.Delete(_PagedFiles.IndexOf(self));
    Free;
  end;
end;

function TPagedFile.CalcRecordCount:Integer;
begin
  if RecordSize = 0 then Result:=0
	else Result:=(Stream.Size - HeaderSize) div RecordSize;
end;

constructor TPagedFile.Create(const FileName: string; Mode: Word);
begin
	if filename='' then Stream:=TMemoryStream.Create()
	else begin
		Stream:=TFileStream.Create(FileName,Mode);
	end;
	HeaderSize:=0;
  RecordSize:=0;
  _cntuse:=0;
  _filename:=lowercase(filename);
  _PagedFiles.Add(Self);
end;

destructor TPagedFile.Destroy;
begin
  Stream.Free;
  Stream:=nil;
  inherited;
end;

procedure TPagedFile._Seek(page:Integer);
var
  p:Integer;
begin
  p:=HeaderSize + (RecordSize * page );
  Stream.Position := p;
end;

Procedure TPagedFile.ReadRecord(IntRecNum:Integer; Buffer:Pointer);
begin
  _Seek(IntRecNum);
  Stream.Read(Buffer^,RecordSize);
end;

procedure TPagedFile.WriteRecord(IntRecNum:Integer; Buffer:Pointer);
begin
  _Seek(IntRecNum);
	Stream.Write(Buffer^, RecordSize);
end;

//====================================================================
// TDbfFile
//====================================================================
constructor TDbfFile.Create(const FileName: string; Mode: Word);
var
  lRecordCount:Integer;
begin
  _MyFieldInfos:=TList.Create;
  // check if the file exists
  inherited Create(Filename, Mode);


  if Mode = fmCreate then begin
    FillChar(_DataHdr,sizeof(_DataHdr),0);
    HeaderSize:=0;
    RecordSize:=0;
    _DataHdr.VerDBF:=$03; // Default version xBaseIV without memo
		_DataHdr.Language:='X';
  end else begin
    Stream.Seek(0,soFromBeginning);
    Stream.ReadBuffer (_DataHdr, SizeOf(_DataHdr));
    case _DataHdr.VerDBF of
    $03,$83:          _DbfVersion:=xBaseIII;
    $04,$8B,$8E,$7B:  _DbfVersion:=xBaseIV;
    $05 :             _DbfVersion:=xbaseV;
    else
      _DbfVersion:=xBaseIV; // My favorite...
    end;
    HeaderSize:=_DataHdr.FullHdrSize;
    RecordSize:=_DataHdr.RecordSize;
    lRecordCount:=CalcRecordCount;
    if _DataHdr.RecordCount <> lRecordCount then begin
      ShowMessage('Invalid Record Count,'+^M+
                                     'RecordCount in Hdr : '+IntToStr(_DataHdr.RecordCount)+^M+
                                     'expected : '+IntToStr(lRecordCount));
      _DataHdr.RecordCount := lRecordCount;
    end;
  end;

end;


destructor TDbfFile.Destroy;
begin
  inherited;
  ClearMyFieldInfos;
  _MyFieldInfos.Free;
  _MyFieldInfos:=nil;

end;

function TDbfFile.RecordCount:integer;
begin
  if RecordSize=0 then result:=0
  else result:=(Stream.Size - HeaderSize) div RecordSize;
  if result<0 then result:=0;
end;

procedure TDbfFile.ClearMyFieldInfos;
var
  i:Integer;
begin
  for i:=0 to _MyFieldInfos.Count-1 do begin
    TMyFieldInfo(_MyFieldInfos.Items[i]).Free;
  end;
  _MyFieldInfos.Clear;
end;

procedure TDbfFile.CreateFieldDefs(FieldDefs:TFieldDefs);
var
  lColumnCount,lHeaderSize,lFieldSize:Integer;
  Il : Integer;
  lFieldOffset : Integer;
  fn:string;
  ft:TFieldType;
  fs,nfs,fd:Integer;
  MyFieldInfo:TMyFieldInfo;
  lFieldHdrIII:rFieldHdrIII;
  lFieldHdrV:rFieldHdrV;

  function ToFieldType(dbasetype:char;fs,fd:Integer):TFieldType;
  begin
    case dbasetype of
    'C' :
      begin
        Result:=ftString;
      end;
    'L' :
      begin
        Result:=ftBoolean;
      end;
    'F' :
      begin
        Result:=ftFloat;
      end;
    'N' :
      begin
        if fd=0 then begin
          if fs <= DIGITS_SMALLINT then begin
            Result:=ftSmallInt;
          end else begin
{$ifdef DELPHI_3}
            Result:=ftInteger;
{$else}
            if fs <= DIGITS_INTEGER then Result:=ftInteger
            else Result:=ftLargeInt;
{$endif}
          end;
        end else begin
          Result:=ftFloat;
        end;
      end;
    'D' :
      begin
        Result:=ftDate;
      end;
    'M' :
      begin
        Result:=ftMemo;
      end;
    else
      begin
        Result:=ftString;
      end;
    end; //case
  end;
begin
  ClearMyFieldInfos;

  if _DbfVersion>=xBaseV then begin
    lHeaderSize:=SizeOf(rAfterHdrV) + SizeOf(rDbfHdr);
    lFieldSize:=SizeOf(rFieldHdrV);
  end else begin
    lHeaderSize:=SizeOf(rAfterHdrIII) + SizeOf(rDbfHdr);
    lFieldSize:=SizeOf(rFieldHdrIII);
  end;
  lColumnCount:= (_DataHdr.FullHdrSize - lHeaderSize) div lFieldSize;

  if (lColumnCount <= 0) or (lColumnCount > 255) then
      Raise eBinaryDataSetError.Create('Invalid field count : ' + IntToStr(lColumnCount) + ' (must be between 1 and 255)');

  lFieldOffset := 1;

  Stream.Position := lHeaderSize;
  for Il:=0 to lColumnCount-1 do begin
    if _DbfVersion>=xBaseV then begin
      Stream.ReadBuffer(lFieldHdrV,SizeOf(lFieldHdrV));
      fn:=PCHAR(@lFieldHdrV.FieldName[0]);
      fs:=lFieldHdrV.FieldSize;
      fd:=lFieldHdrV.FieldPrecision;
      nfs:=fs;
      ft:=ToFieldType(lFieldHdrV.FieldType,nfs,fd);
    end else begin
      Stream.ReadBuffer(lFieldHdrIII,SizeOf(lFieldHdrIII));
      fn:=PCHAR(@lFieldHdrIII.FieldName[0]);
      fs:=lFieldHdrIII.FieldSize;
      fd:=lFieldHdrIII.FieldPrecision;
      nfs:=fs;
      ft:=ToFieldType(lFieldHdrIII.FieldType,nfs,fd);

    end;
    // first create the bde field
    if ft in [ftString,ftBCD] then fieldDefs.Add(fn,ft,fs,false)
    else fieldDefs.Add(fn,ft,0,false);
    // then create the for our own fieldinfo
    MyFieldInfo:=TMyFieldInfo.Create;
    MyFieldInfo.Offset:=lFieldOffset;
    MyFieldInfo.Size:=fs;
    MyFieldInfo.Prec:=fd;
    MyFieldInfo.FieldName:=lowercase(fn);

    _MyFieldInfos.Add(MyFieldInfo);
    Inc(lFieldOffset,fs);
  end;
  if (lFieldOffset <> _DataHdr.RecordSize) then begin
    ShowMessage('Invalid Record Size,'+^M+
                                     'Record Size in Hdr : '+IntToStr(_DataHdr.RecordSize)+^M+
                                     'Expected : '+IntToStr(lFieldOffset));
    _DataHdr.RecordSize := lFieldOffset;
  end;
end;

procedure TDbfFile.DbfFile_CreateTable(FieldDefs:TFieldDefs);
var
  ix:Integer;
  lFieldHdrIII:rFieldHdrIII;
  lType:Char;
  lSize,lPrec:Integer;
  Offs:Integer;
  lterminator:Byte;
begin
  // first reset file.
  Stream.Size:= 0;
  Stream.Position:=SizeOf(rDbfHdr) + SizeOf(rAfterHdrIII);
  Offs:=1; // deleted mark count 1.
  for Ix:=0 to FieldDefs.Count-1 do
  begin
    with FieldDefs.Items[Ix] do
    begin
      FillChar(lFieldHdrIII,SizeOf(lFieldHdrIII),#0);
      lPrec:=0;
      case DataType of
        ftString:
          begin
            ltype:='C';
            lSize := Size;
          end;
        ftBoolean:
          begin
            ltype:='L';
            lSize := 1;
          end;
        ftSmallInt:
          begin
            ltype:='N';
            lSize := 6;
          end;
        ftInteger:
          begin
            ltype:='N';
            lSize := 11;
          end;
				ftCurrency:
					begin
						ltype:='N';
						lSize := 20;
						lPrec := 2;
					end;
{$ifndef DELPHI_3}
				ftLargeInt:
					begin
						ltype:='N';
						lSize := 20;
						lPrec := 0;
					end;
{$endif}