dbf.pas

很管用的GIS控件

        ftFloat:
          begin
            ltype:='N';
            lSize := 20;
            lPrec := 4;
          end;
        ftDate:
          begin
            ltype:='D';
            lSize := 8;
          end;
        ftMemo:
          begin
            ltype:='M';
            lSize := 10;
          end;
        else
          begin
            raise EBinaryDataSetError.Create(
             'InitFieldDefs: Unsupported field type');
          end;
      end; // case

      lFieldHdrIII.FieldType:=ltype; //DataType;
      StrPCopy(lFieldHdrIII.FieldName,FieldDefs.Items[Ix].Name);
      lFieldHdrIII.FieldSize:=lSize;
      lFieldHdrIII.FieldPrecision:=lPrec;

      Stream.Write(lFieldHdrIII,SizeOf(lFieldHdrIII));
      Inc(Offs,lSize);
    end;
  end;
  // end of header
  lterminator := $0d;
  Stream.Write(lterminator,SizeOf(lterminator));

  // update header
  _DataHdr.RecordSize := Offs;
  _DataHdr.FullHdrSize := Stream.Position;
  RecordSize := _DataHdr.RecordSize;
  HeaderSize := _DataHdr.FullHdrSize;
  // write the updated header
  WriteHeader;
end;

procedure TDbfFile.DbfFile_PackTable;
var
  first,last:integer;
  p: Pointer;
begin
  // Non tested.
  if (RecordSize <> 0) then
  begin
    first:=0;
    last:=CalcRecordCount-1;
    GetMem(p, RecordSize);
		try
      while first<last do begin
        // first find the first hole
        while first<last do begin
					ReadRecord(first, p);
					if (pRecordHdr(p)^.DeletedFlag <> ' ') then break;
					inc(first);
				end;
				// now find last one non deleted.
				while first<last do begin
					ReadRecord(last, p);
					if (pRecordHdr(p)^.DeletedFlag = ' ') then break;
					dec(last);
				end;
        if first<last then begin
          // found a non deleted record to put in the hole.
          WriteRecord(first, p);
					inc(first);
					dec(last);
        end;
      end;
		last:=CalcRecordCount;
			Stream.Size:=(last+1) * RecordSize + HeaderSize;
    finally
      FreeMem(p);
    end;
	end;
end;

function TDbfFile.GetFieldInfo(FieldName:string):TMyFieldInfo;
var
  i:Integer;
  lfi:TMyFieldInfo;
begin
  FieldName:=LowerCase(FieldName);
  for i:=0 to _MyFieldInfos.Count-1 do begin
    lfi:=TMyFieldInfo(_MyFieldInfos.Items[i]);
    if lfi.FieldName = FieldName then begin
      result:=lfi;
      exit;
    end;
  end;
  result:=nil;
end;

function TDbfFile.GetFieldData(Column:Integer;DataType:TFieldType; Src,Dst:Pointer): Boolean;
var
  FieldOffset: Integer;
  FieldSize: Integer;
  s:string;
  d:TDateTime;
  ld,lm,ly: word;
  MyFieldInfo:TMyFieldInfo;

	function TrimStr(const s: string): string;
	begin
		if DataType=ftString then
		begin
			if tDbf_TrimFields then Result:=Trim(s)
			else Result:=TrimRight(s);
		end
		else Result:= Trim(s);
	end;
  
  procedure CorrectYear(var wYear: word);
  var wD, wM, wY, CenturyBase: word;
{$ifdef DELPHI_3}
  // Delphi 3 standard-behavior no change possible
  const TwoDigitYearCenturyWindow= 0;
{$endif}
  begin
     if wYear>= 100 then
       Exit;
     DecodeDate(Date, wY, wm, wD);
     // use Delphi-Date-Window
     CenturyBase := wY{must be CurrentYear} - TwoDigitYearCenturyWindow;
     Inc(wYear, CenturyBase div 100 * 100);
     if (TwoDigitYearCenturyWindow > 0) and (wYear < CenturyBase) then
        Inc(wYear, 100);
  end;
begin
  MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  FieldOffset := MyFieldInfo.Offset;
	FieldSize := MyFieldInfo.Size;
  SetString(s, PChar(Src) + FieldOffset, FieldSize );
	s:=TrimStr(s);
  result:=length(s)>0; // return if field is empty
  if Result and (Dst<>nil) then// data not needed if Result= FALSE or Dst=nil
    case DataType of
    ftBoolean:
      begin
        // in DBase- FileDescription lowercase t is allowed too
        // with asking for Result= TRUE s must be longer then 0
        // else it happens an AV, maybe field is NULL
        if (UpCase(s[1])='T') then Word(Dst^) := 1
        else Word(Dst^) := 0;
      end;
    ftInteger, ftSmallInt{$ifndef DELPHI_3},ftLargeInt{$endif}:
      begin
        case DataType of
        ftSmallInt : SmallInt(Dst^):= StrToIntDef(s, 0);
        {$ifndef DELPHI_3}
        ftLargeint : LargeInt(Dst^):= StrToInt64Def(s, 0);
				{$endif}
        else // ftInteger :
          Integer(Dst^):= StrToIntDef(s, 0);
        end; // case
      end;
    ftFloat:
      begin
        Double(Dst^) := DBFStrToFloat(s);
      end;
    ftCurrency:
      begin
        Double(Dst^) := DBFStrToFloat(s);
      end;
    ftDate:
      begin
        ld:=StrToIntDef(Copy(s,7,2),1);
        lm:=StrToIntDef(Copy(s,5,2),1);
        ly:=StrToIntDef(Copy(s,1,4),0);
        if ld=0 then ld:=1;
        if lm=0 then lm:=1;
//           if (ly<1900) or (ly>2100) then ly:=1900;
//           Year from 0001 to 9999 is possible
//           everyting else is an error, an empty string too
//           Do DateCorrection with Delphis possibillities for one or two digits
				if (ly< 100) and (Length(Trim(Copy(s,1,4)))in [1, 2]) then CorrectYear(ly);
				try
					d:=EncodeDate(ly,lm,ld);
					if Assigned(Dst) then  Integer(Dst^) := DateTimeToTimeStamp(d).Date;
				except
					Integer(Dst^) := 0;
				end;
			end;
				ftString: begin
				StrPCopy(Dst,s);
			end;
	 end;
end;

procedure TDbfFile.SetFieldData(Column:integer;DataType:TFieldType; Src,Dst:Pointer);
var
  FieldSize,FieldPrec: Integer;
	s:string;
  fl:Double;
  ts:TTimeStamp;
  MyFieldInfo:TMyFieldInfo;
begin
  MyFieldInfo:=TMyFieldInfo(_MyFieldInfos.Items[Column]);
  FieldSize := MyFieldInfo.Size;
  FieldPrec := MyFieldInfo.Prec;

	Dst:=PChar(Dst)+MyFieldInfo.Offset;
	if src<>nil then begin
		case DataType of
		ftBoolean:
			begin
				if Word(Src^) = 1 then s:='T'
				else s:='F';
			end;
		ftInteger, ftSmallInt {$ifndef DELPHI_3},ftLargeInt{$endif}:
			begin
				case DataType of
				ftSmallInt : s:= IntToStr(SmallInt(Src^));
        {$ifndef DELPHI_3}
        ftLargeInt: s:= IntToStr(LargeInt(Src^));
        {$endif}
				else //ftInteger
					s:= IntToStr(Integer(Src^));
				end;
				// left filling
				if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
			end;
		ftFloat,ftCurrency:
			begin
				fl := Double(Src^);
				s:=FloatToDbfStr(fl,FieldSize,FieldPrec);
				if Length(s)<FieldSize then s:=StringOfChar(' ',FieldSize-Length(s)) + s;
			end;
		ftDate:
			begin
				ts.Time:=0;
				ts.Date:=Integer(Src^);
				s:= FormatDateTime('yyyymmdd', TimeStampToDateTime(ts));
			end;
		ftString:
			begin
				s:=PChar(Src); // finish with first 0
			end;
		end; // case
	end; // if src<>nil (thanks andreas)
	if Length(s)<FieldSize then begin
		s:=s+StringOfChar(' ',FieldSize-Length(s));
	end else if (Length(s)>FieldSize) then begin
		if DataType= ftString then begin
			// never raise for strings to long, its not customary
			// TTable never raises
			SetLength(s, FieldSize)
		end else begin
			raise eFieldToLongError.Create('Fielddata too long :' + IntToStr(Length(s))
				+ ' (must be between 1 and ' + IntToStr(FieldSize) + ').');
		end;
	end;
	Move(PChar(s)^, Dst^, FieldSize);
end;


procedure TDbfFile.WriteHeader;
var
	SystemTime: TSystemTime;
	lAfterHdrIII:rAfterHdrIII;
	lAfterHdrV:rAfterHdrV;
	lterminator:Byte;
begin
  Assert(Stream<>nil,'_dbfFile=Nil');

  Stream.Position:=0;
  GetLocalTime(SystemTime);
  _DataHdr.Year := SystemTime.wYear - 1900;
  _DataHdr.Month := SystemTime.wMonth;
  _DataHdr.Day := SystemTime.wDay;
  Stream.Seek(0,soFromBeginning);
  Stream.WriteBuffer (_DataHdr, SizeOf(_DataHdr));
  _DataHdr.RecordCount := CalcRecordCount;

  if _DbfVersion >= xBaseV then begin
    FillChar(lAfterHdrV,SizeOf(lAfterHdrV),0);
    Stream.WriteBuffer (lAfterHdrV, SizeOf(lAfterHdrV));
  end else begin
    FillChar(lAfterHdrIII,SizeOf(lAfterHdrIII),0);
    Stream.WriteBuffer (lAfterHdrIII, SizeOf(lAfterHdrIII));
  end;
  _Seek(_DataHdr.RecordCount); // last byte usually...
  lterminator := $1A;
  Stream.Write(lterminator,SizeOf(lterminator));
end;

function TDbf._ComponentInfo:string;
begin
  Result:='TDbf V' + IntToStr(_MAJOR_VERSION) + '.' + IntToStr(_MINOR_VERSION);
end;

procedure TDbf._OpenFiles(Create:boolean);
var
  fileopenmode : integer;
  lPath,lFilename,lIndexName,lMemoName : string;
  design,readonly:boolean;
  isAbsolute:boolean;
begin
  design:=(csDesigning in ComponentState);
  readonly:=design or _ReadOnly;

  lPath:=_GetPath;
  isAbsolute:=((length(_TableName)>=1) and (_TableName[1]='\'))
    or ((length(_TableName)>=2) and (_TableName[2]=':'));
  if isAbsolute then lfilename:=_TableName
  else lFilename:=lPath+_TableName;
  lFilename:=ChangeFileExt(lFilename,'.dbf');
  lIndexName:=ChangeFileExt(lFilename,'.mdx');
  lMemoName:=ChangeFileExt(lFilename,'.dbt');

  // check if the file exists
  _dbfFile:=TDbfFile(GetPagedFile(lFileName));
  _indexFile:=TIndexFile(GetPagedFile(lIndexName));
  _dbtFile:=TDbtFile(GetPagedFile(lMemoName));

  if Create then begin
    if _dbfFile=nil then _dbfFile:=TDbfFile.Create(lFileName,fmCreate);
    //if _indexfile=nil then _indexFile := TIndexFile.Create(lIndexName, fmCreate);
    if _dbtfile=nil then _dbtFile := TDbtFile.Create(lMemoName, fmCreate,_dbfFile._DbfVersion);
  end else if not FileExists(lFileName) then begin
    raise eBinaryDataSetError.Create ('Open: Table file not found : ' + lFileName);
  end else begin
    if ReadOnly  then
      fileopenmode := fmOpenRead + fmShareDenyNone
    else
      fileopenmode := fmOpenReadWrite + fmShareDenyWrite;

    if _dbfFile=nil then _dbfFile := TDBFFile.Create(lFileName, fileopenmode);
    if (_indexFile=nil) and FileExists (lIndexName) then begin
      _indexFile := TIndexFile.Create(lIndexName, fileopenmode);
    end;
    if (_dbtFile=nil) and FileExists (lMemoName) then begin
      _dbtFile := TDbtFile.Create(lMemoName, fileopenmode,_dbfFile._DbfVersion);
    end;
  end;
  _PrevBuffer:=AllocRecordBuffer;
  _IsCursorOpen:=true;

end;

function TDbf._GetPath:string;
var
  lPath:string;
begin
  if (csDesigning in ComponentState) then begin
    lPath:=_DesignTimePath;
  end else begin
    if ((length(_RunTimePath)>=1) and (_RunTimePath[1]='\'))
      or ((length(_RunTimePath)>=2) and (_RunTimePath[2]=':'))
      then begin
      // if the _RunTimePath is absolute...
      // it is either \ or \blahblah or c:\
      lPath:=_RunTimePath;
    end else begin
      lPath:=extractfilepath(Application.Exename)+_RunTimePath;
    end;
  end;
  lPath:=ExpandFileName(trim(lPath));
  if (length(lPath)>0) and (lPath[length(lPath)]<>'\') then lPath:=lPath+'\';
  result:=lPath;
end;

procedure TDbf._CloseFiles;
var
  i:integer;
begin
  if _dbfFile<>nil then begin
    if not _ReadOnly then _dbfFile.WriteHeader;
    _dbfFile.Release;
    _dbfFile:=nil;
  end;
  if _indexFile<>nil then begin
    _indexFile.Release;
    _indexFile:=nil;
  end;

  if _dbtFile<>nil then begin
    _dbtFile.Release;
    _dbtFile:=nil;
  end;

  if _indexes<>nil then begin
    for i:=0 to _Indexes.Count-1 do begin
      TIndex(_Indexes[i]).Free;
    end;
    _Indexes.Clear;
    _CurIndex:=nil;
  end;
  if (_PrevBuffer<>nil) then begin
    FreeRecordBuffer(_PrevBuffer);
    _PrevBuffer:=nil;
  end;
  _IsCursorOpen:=false;
end;

procedure TDbf._SetIndexName(const Value: string);
begin
  _CurIndex:=_GetIndex(Value);
  Resync([]);
end;

function TDbf._GetIndexName: string;
begin
  if _CurIndex=nil then Result:=''
  else Result:=_CurIndex._IndexFile._Filename;
end;

function TDbf._GetIndex(filename:string):TIndex;
var
  i:integer;
  lindex:TIndex;
begin
  result:=nil;
  filename:=lowercase(_GetPath + filename);
  for i:=0 to _indexes.Count-1 do begin
    lindex:=TIndex(_indexes.Items[i]);
    if lindex._IndexFile._Filename=filename then begin
      result:=lindex;
      exit;
    end;
  end;
end;


//==========================================================
//============ TMyBlobFile
//==========================================================
constructor TMyBlobFile.Create(ModeVal:TBlobStreamMode;FieldVal:TField);
begin
  Mode:=ModeVal;
  Field:=FieldVal;
end;

destructor TMyBlobFile.destroy;
var
  Dbf:TDbf;
begin
  if (Mode=bmWrite) then begin
    Size:=Position; // Strange but it leave tailing trash bytes if I do not write that.
    Dbf:=TDbf(Field.DataSet);
    Dbf._dbtFile.WriteMemo(MemoRecno,ReadSize,Self);

    Dbf._dbfFile.SetFieldData(Field.FieldNo-1,
      ftInteger,@MemoRecno,@pDbfRecord(TDbf(Field.DataSet).ActiveBuffer).deletedflag);
    // seems not bad
    Dbf.SetModified(true);
    // but would that be better
    //if not (State in [dsCalcFields, dsFilter, dsNewValue]) then begin
    //  DataEvent(deFieldChange, Longint(Field));