dxdatasetbintree.pas

Well known and usefull component for delphi 7

   if FieldNo>1 then
      for x:=1 to FieldNo-1 do Inc(offs,DXTabGetFieldSize(x)+DXBoolSize);
   Result:=SizeOf(FRealRecNo)+offs;
end;

function TDXDataSetBinaryTree.DXTabGetFieldPointer(Buffer: PChar; Field: TField): PChar;
begin
   Result:=Buffer;
   if Buffer=nil then exit;
   if Field.FieldNo<=0 then Inc(Result,FStartCalculated+Field.Offset)
   else Inc(Result,DXTabGetFieldOffset(Field.FieldNo-1));
end;

function TDXDataSetBinaryTree.DXTabGetFieldSize(FieldNo: integer): Integer;
// ftBCD
// ftBytes
// ftVarBytes
// ftTypedBinary
// ftCursor
begin
   Result:=DXIntSize;
   case FieldDefs.Items[FieldNo-1].Datatype of
     ftString:Result:=FieldDefs.Items[FieldNo-1].Size+1;
     ftBoolean,
     ftWord,
     ftSmallInt:Result:=2;
     ftFloat,
     ftCurrency,
     ftDate,
     ftTime,
     ftDateTime:Result:=8;
     ftAutoInc,
     ftFmtMemo,
     ftParadoxOle,
     ftDBaseOle,
     ftInteger,
     ftBlob,
     ftMemo,
     ftVarBytes,
     ftGraphic:Result:=DXIntSize;
{$IFNDEF VER100}
     ftDataSet:Result:=DXIntSize;
{$ENDIF}
     else
{$IFDEF VER100}
        DatabaseError('Fieldtype of Field "'+FieldDefs.Items[FieldNo-1].Name+'" not supported!');
{$ELSE}
        DatabaseError('Fieldtype of Field "'+FieldDefs.Items[FieldNo-1].Name+'" not supported!',Self);
{$ENDIF}
   end;
end;

procedure TDXDataSetBinaryTree.DXTabInsertRecord(RecNo: Integer; Buffer: PChar);
begin
   FLastBookmark:=FDataList.Count+1;
   FDatalist.AppendRow(FLastBookMark);
   FDatalist.PutToBuffer(Buffer,FLastBookMark);
end;

function TDXDataSetBinaryTree.IsFieldNull(FieldNo: Integer): Boolean;
var
   SrcBuffer:PChar;

begin
   Result:=False;
   if not DXTabGetActiveBuffer(SrcBuffer) then Exit;
   FastMove((SrcBuffer+DXTabGetFieldOffset(FieldNo)+DXTabGetFieldSize(FieldNo))^,Result,DXBoolSize);
end;

procedure TDXDataSetBinaryTree.SetFieldNull(FieldNo: Integer; IsNull :Boolean);
var
   SrcBuffer:PChar;

begin
   if not DXTabGetActiveBuffer(SrcBuffer) then Exit;
   FastMove(IsNull,(SrcBuffer+DXTabGetFieldOffset(FieldNo)+DXTabGetFieldSize(FieldNo))^,DXBoolSize);
end;

procedure TDXDataSetBinaryTree.CreateTable;
var
   i:Integer;

begin
   FBlobCount:=0;
   FBlobRecSize:=0;
   FRecordPos:=0;
   FIsOpen:=False;
   FRecordSize:=0;
   if FieldDefs.Count>0 then
      for i:=0 to FieldDefs.Count-1 do begin
         if FieldDefs.Items[i].DataType in [ftMemo, ftBlob, ftGraphic, ftVarBytes] then begin
            inc(FBlobCount);
            Inc(FBlobRecSize,FBlobSize);
         end;
         Inc(FRecordSize,DXTabGetFieldSize(i+1)+DXBoolSize); // NULL value
      end;
   Inc(FRecordSize,DXIntSize);
// ???
   FDataList.RecordSize:=FRecordSize;
   FBookmarkInfoOffset:=FRecordSize; //
   FRecBufferSize:=FRecordSize+FBookmarkInfoSize+CalcFieldsSize;
   FStartCalculated:=FRecordSize+SizeOf(TDXBookmarkInfo);
end;

function TDXDataSetBinaryTree.FieldDefsStored: Boolean;
begin
   Result:=StoreDefs and (FieldDefs.Count>0);
end;

procedure TDXDataSetBinaryTree.ClearCalcFields(Buffer: PChar);
begin
   FillChar2(Buffer[FStartCalculated],CalcFieldsSize,#0);
end;

function TDXDataSetBinaryTree.LocateNext(const KeyFields: String;
                                  const KeyValues: Variant;
                                  Options: TLocateOptions): Boolean;
var
   CurBookmark:String;

begin
   CheckActive;
   CurBookmark:=Bookmark;
   DisableControls;
try
   FDoEvents:=False;
   Result:=InternalLocate(KeyFields,KeyValues,Options,False);
   if not Result then Bookmark:=CurBookmark
finally
   FDoEvents:=True;
   EnableControls;
end;
end;

function TDXDataSetBinaryTree.Locate(const KeyFields: String;
                              const KeyValues: Variant;
                              Options: TLocateOptions): Boolean;
begin
   CheckActive;
   DoBeforeScroll;
try
   FDoEvents:=False;
   Result:=InternalLocate(KeyFields, KeyValues, Options, True);
finally
   FDoEvents:=True;
end;
   if Result then begin
      Resync([rmExact,rmCenter]);
      DoAfterScroll;
   end;
end;

function TDXDataSetBinaryTree.InternalLocate(const KeyFields :String;
                                            const KeyValues :Variant;
                                            Options :TLocateOptions;
                                            FromStart :Boolean) :Boolean;
var
   V:Variant;
   BM:String;
   FList:TList;
   i,FCount:Integer;

function StringMatch(S:String):Boolean;
var
   aString,bString:String;

begin
   bString:=TrimRight(s);
   if loPartialKey in Options then aString:=TrimRight(VarToStr(V))
   Else aString:=VarToStr(v);
   if loCaseInsensitive in Options then begin
      aString:=Lowercase(aString);
      bString:=Lowercase(bString);
   End;
   if loPartialKey in Options then Begin
      Result:=Pos(aString,bString)=1;
   end
   else Result:=CompareText(aString,bString)=0;
end;

function Match:Boolean;
var
   j:Integer;

begin
   Result:=True;
   for j:=0 to FCount-1 do begin
      if FCount>1 then v:=KeyValues[j];
      if FieldByName(TField(FList[j]).FieldName).DataType in [ftString {$IFNDEF VER100}, ftFixedChar, ftDataSet{$ENDIF} {$IFDEF VER130}, ftGuid {$ENDIF}] then
         Result:=StringMatch(FieldByName(TField(FList[j]).FieldName).AsString)
      else
         Result:=FieldByName(TField(FList[j]).FieldName).Value=v;
      if not Result then exit;
   end;
end;

begin
   Result:=False;
try
   bm:=BookMark;
   FList:=Tlist.Create;
   GetFieldList(FList,KeyFields);
   FCount:=Flist.Count;
   if FCount=1 then begin
      if VarisArray(KeyValues) then v:=KeyValues[0]
      else v:=KeyValues
   end
   else begin
      FIgnoreSetFieldChk:=True;
try
      for i:=0 to FCount - 1 do
          TField(FList[i]).Value:=KeyValues[I];
finally
      FIgnoreSetFieldChk:=False;
end;
   end;
   if FromStart then First
   else next;
   DisableControls;
   while not Eof do begin
      Result:=Match;
      if Result then break else Next;
   end;
   if Result then bm:=BookMark;
finally
try
   BookMark:=bm;
except
end;
   FList.Free;
   EnableControls;
end;
end;

function TDXDataSetBinaryTree.Lookup(const KeyFields: String;
                              const KeyValues: Variant;
                              const ResultFields: String): Variant;
var
   CurBookmark:TBookmarkStr;

begin
   DisableControls;
   CurBookmark:=Bookmark;
try
   Result:= Null;
   if InternalLocate(KeyFields,KeyValues,[],True) then begin
      SetTempState(dsCalcFields);
try
      CalculateFields(TempBuffer);
      Result:=FieldValues[ResultFields];
finally
      RestoreState(dsBrowse);
end;
   end;
finally
   Bookmark:=CurBookmark;
   EnableControls;
end;
end;

function TDXDataSetBinaryTree.GetCanModify: Boolean;
begin
   Result:=inherited GetCanModify and not ReadOnly
end;

procedure TDXDataSetBinaryTree.SetReadOnly(Value: Boolean);
begin
   CheckInactive;
   FReadOnly:=Value;
end;

procedure TDXDataSetBinaryTree.StoreMemoryStream(Field: TField; M: TMemoryStream);
var
   BlobID:Integer;
   TmpStream:TMemoryStream;
   PBlobSpot:PChar;

begin
   PBlobSpot:=DXGetFieldData(RecNo,Field);
   FastMove(PBlobSpot,BlobId,DXIntSize);
   if (M.Size=0) then SetFieldNull(Field.FieldNo,True);
   if (BlobId<=0) or (State=dsInsert) then begin
      if (M.Size=0) and (State in [dsInsert]) then exit;
      BlobId:=FBlobList.AddBlobAutoInc(M,Field.FieldNo);
      SetFieldData(Field, @BlobId);
   end
   else begin
      TmpStream:=FBlobList.GetBlob(Blobid,Field.FieldNo);
      FBlobList.BlobModifiedSet(Blobid,Field.FieldNo,True);
      if TmpStream=nil then exit;
      TmpStream.LoadFromSTream(m);
      TmpStream.position:=0;
   end;
end;

function TDXDataSetBinaryTree.CreateBlobStream(Field: TField;
  Mode: TBlobStreamMode): TStream;
begin
   Result:=TDXBlobStream.Create(Field as TBlobField,Mode);
end;

function TDXDataSetBinaryTree.IsBlobField(F: TField): Boolean;
begin
   case F.DataType of
      ftBlob..ftCursor:Result:=True;
      ftBytes,ftVarbytes:Result:=True;
{$IFNDEF VER100}
      ftAdt..ftDataSet:Result:=True;
{$ENDIF}
      else Result:=False;
   end;
end;

Procedure TDXDataSetBinaryTree.ResetBookmarkFlags;
var
   OldCurrent:TBookmarkStr;

begin
   OldCurrent:=Bookmark;
   DisableControls;
try
   First;
   while not Eof do begin
      SetBookmarkFlag(ActiveBuffer, bfInserted);
      Next;
   end;
finally
   Bookmark:=OldCurrent;
   EnableControls;
end;
end;

procedure TDXDataSetBinaryTree.CheckOpen;
begin
   if Active then
{$IFDEF VER100}
      DatabaseError(SDataSetOpen);
{$ELSE}
      DatabaseError(SDataSetOpen,Self);
{$ENDIF}
end;

function TDXDataSetBinaryTree.FindRecord(Restart, GoForward: Boolean): Boolean;
var
   Bm:TBookmarkStr;
   Done:Boolean;

begin
   Result:=False;
try
   bm:=BookMark;
   DisableControls;
   Done:=False;
   Case Restart of
      True:If GoForward then Begin
           First;
           Done:=Eof;
           End
           Else Last;
      False:If GoForward then Next
            Else Begin
            Prior;
            Done:=Bof;
      End;
   End;
   While not done do Begin
      if not Filtered then Result:=True
      else OnFilterRecord(self,Result);
      if Result then break
      else Begin
         If GoForward then Begin
            Next;
            Done:=Eof;
         End
         Else Begin
            Prior;
            Done:=Bof;
         End;
      End;
   End;
   if Result then Bm:=BookMark;
finally
   BookMark:=Bm;
   EnableControls;
end;
end;

function TDXDataSetBinaryTree.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Integer;
const
   RetCodes:Array[Boolean,Boolean] of ShortInt=((2,-1),(1,0));

begin
   Result:=RetCodes[Bookmark1=nil,Bookmark2=nil];
   if Result=2 then begin
      Result:=Integer(BookMark1^)-Integer(BookMark2^);
      if Result<0 then Result:=-1
      else if Result>0 then Result:=1
   end;
end;

function TDXDataSetBinaryTree.GetMemoryStream(Field:TField):TMemoryStream;
var
   Blobspot:Integer;
   PBlobSpot:PChar;

begin
   Result:=nil;
   if not Active then exit;
   case State of
      dsEdit:begin
         GetFieldData(Field,@BlobSpot);
         Result:=FBlobList.GetBlob(BlobSpot,Field.FieldNo);
         if Result=nil then begin
            BlobSpot:=FBlobList.AddBlobAutoInc(nil, Field.FieldNo);
            Result:=FblobList.GetBlob(BlobSpot, Field.FieldNo);
            SetFieldData(Field,@BlobSpot);
         end;
      end;
      dsInsert:begin
         PBlobSpot:=DXGetFieldData(RecNo,Field);
         FastMove(PBlobSpot,BlobSpot,DXIntSize);
         Result:=FBlobList.GetBlob(BlobSpot,Field.FieldNo);
         if Result=nil then begin
            BlobSpot:=FBlobList.AddBlobAutoInc(nil,Field.FieldNo);
            Result:=FBlobList.GetBlob(BlobSpot,Field.FieldNo);
            SetFieldData(Field, @BlobSpot);