bdeutils.pas

rxlib2.75控件包

end;

function TDBLocate.LocateFilter: Boolean;
var
  SaveCursor: TCursor;
begin
  if LookupExact or (LookupField.DataType = ftString) or
    not (DataSet is TDBDataSet) then
    Result := inherited LocateFilter
  else begin
    SaveCursor := Screen.Cursor;
    Screen.Cursor := crHourGlass;
    try
      Result := LocateCallback;
    finally
      Screen.Cursor := SaveCursor;
    end;
  end;
end;

{$ELSE WIN32}

type
  TFilterRec = record { the simple filter tree with one condition }
    Header: CANExpr;
    Condition: CANBinary;
    FieldNode: CANField;
    ConstNode: CANConst;
  end;

function TDBLocate.LocateFilter: Boolean;
var
  SaveCursor: TCursor;
  Status: DBIResult;
begin
  SaveCursor := Screen.Cursor;
  Screen.Cursor := crHourGlass;
  try
    ActivateFilter;
    try
      Check(DbiSetToBegin(TBDEDataSet(DataSet).Handle));
      Status := DbiGetNextRecord(TBDEDataSet(DataSet).Handle, dbiNoLock,
        nil, nil);
      if Status = DBIERR_NONE then begin
        DataSet.Resync([rmExact, rmCenter]);
        ChangeBookmark;
        Result := True;
      end
      else Result := False;
    finally
      DeactivateFilter;
      if Result then SetToBookmark(DataSet, Bookmark);
    end;
  finally
    Screen.Cursor := SaveCursor;
  end;
end;

procedure TDBLocate.BuildFilterHeader(var Rec);
const
  FCondition: array[Boolean] of CANOp = (canGE, canEQ);
  FilterHeaderSize = SizeOf(CANExpr) + SizeOf(CANBinary) +
    SizeOf(CANField) + SizeOf(CANConst);
begin
  with TFilterRec(Rec) do begin
    with Header do begin
      iVer := CANEXPRVERSION;
      iNodes := 3;
      iNodeStart := SizeOf(CANExpr);
      iLiteralStart := FilterHeaderSize;
    end;
    with Condition do begin
      nodeClass := nodeBINARY;
      canOp := FCondition[LookupExact];
      iOperand1 := SizeOf(CANBinary);
      iOperand2 := iOperand1 + SizeOf(CANField);
    end;
    with FieldNode do begin
      nodeClass := nodeFIELD;
      canOp := canFIELD2;
      iFieldNum := LookupField.FieldNo;
      iNameOffset := 0;
    end;
    with ConstNode do begin
      canOp := canCONST2;
      iType := FieldLogicMap(LookupField.DataType);
      iSize := LookupField.DataSize;
      iOffset := Length(LookupField.FieldName) + 1;
    end;
    Header.iTotalSize := FilterHeaderSize + ConstNode.iSize +
      ConstNode.iOffset;
  end;
end;

procedure TDBLocate.BuildFilterTree;
var
  Temp: PChar;
  Rec: TFilterRec;
begin
  if FTree <> nil then FreeMem(FTree, FTreeSize);
  FTree := nil;
  BuildFilterHeader(Rec);
  FTreeSize := Rec.Header.iTotalSize;
  FTree := AllocMem(FTreeSize);
  try
    FillChar(FTree^, FTreeSize, 0);
    Temp := FTree;
    Move(Rec, FTree^, SizeOf(TFilterRec));
    Inc(Temp, SizeOf(TFilterRec));
    StrPCopy(PChar(Temp), LookupField.FieldName);
    Inc(Temp, Rec.ConstNode.iOffset);
    ConvertStringToLogicType(DataSet.Locale, FieldLogicMap(LookupField.DataType),
      LookupField.DataSize, LookupField.FieldName, LookupValue, Temp);
  except
    FreeTree;
    raise;
  end;
end;

procedure TDBLocate.FreeTree;
begin
  if FTree <> nil then FreeMem(FTree, FTreeSize);
  FTree := nil;
  FTreeSize := 0;
end;

procedure TDBLocate.CheckFilterKind;
var
  NewKind: TLocateFilter;
begin
  if CaseSensitive and LookupExact then NewKind := lfTree
  else NewKind := lfCallback;
  if (FFilterKind <> NewKind) or (NewKind = lfTree) then begin
    DropFilter;
    FFilterKind := NewKind;
  end;
end;

procedure TDBLocate.ActivateFilter;
begin
  CheckFilterKind;
  if FFilterHandle = nil then begin
    if FFilterKind = lfCallback then begin
      Check(DbiAddFilter(DataSet.Handle, Longint(Self), 0, True, nil,
        CallbackFilter, FFilterHandle));
    end
    else { lfTree } begin
      BuildFilterTree;
      Check(DbiAddFilter(DataSet.Handle, 0, 1, False,
        pCANExpr(FTree), nil, FFilterHandle));
    end;
  end;
  DbiActivateFilter(DataSet.Handle, FFilterHandle);
end;

procedure TDBLocate.DeactivateFilter;
begin
  DbiDeactivateFilter(DataSet.Handle, FFilterHandle);
end;

procedure TDBLocate.DropFilter;
begin
  if FFilterHandle <> nil then
    DbiDropFilter(DataSet.Handle, FFilterHandle);
  FreeTree;
  FFilterHandle := nil;
end;

function TDBLocate.RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
var
  Accept: Boolean;
begin
  try
    Move(RecBuf^, DataSet.ActiveBuffer^, DataSet.RecordSize);
    if LookupField <> nil then Accept := MatchesLookup(LookupField)
    else Accept := True;
    Result := Ord(Accept);
  except
    Application.HandleException(Self);
    Result := ABORT;
  end;
end;

procedure TDBLocate.ChangeBookmark;
begin
  if Bookmark <> nil then DataSet.FreeBookmark(Bookmark);
  Bookmark := DataSet.GetBookmark;
end;

procedure TDBLocate.ActiveChanged;
begin
  DropFilter;
end;

{$ENDIF WIN32}

{ DataSet locate routines }

function IsFilterApplicable(DataSet: TDataSet): Boolean;
var
  Status: DBIResult;
  Filter: hDBIFilter;
begin
  if DataSet is TBDEDataSet then begin
    Status := DbiAddFilter(TBDEDataSet(DataSet).Handle, 0, 0, False, nil,
      nil, Filter);
    Result := (Status = DBIERR_NONE) or (Status = DBIERR_INVALIDFILTER);
    if Result then DbiDropFilter(TBDEDataSet(DataSet).Handle, Filter);
  end
  else Result := True;
end;

function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, True, False);
  finally
    Free;
  end;
end;

function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
begin
  with TDBLocate.Create do
  try
    DataSet := ADataSet;
    if ADataSet is TDBDataSet then
      IndexSwitch := not TDBDataSet(DataSet).Database.IsSQLBased;
    Result := Locate(FieldName, Value, False, False);
  finally
    Free;
  end;
end;

const
  SaveIndexFieldNames: TStrings = nil;

procedure UsesSaveIndexies;
begin
  if SaveIndexFieldNames = nil then
    SaveIndexFieldNames := TStringList.Create;
end;

procedure ReleaseSaveIndexies; far;
begin
  if SaveIndexFieldNames <> nil then begin
    SaveIndexFieldNames.Free;
    SaveIndexFieldNames := nil;
  end;
end;

procedure SetIndex(Table: TTable; const IndexFieldNames: string);
var
  IndexToSave: string;
begin
  IndexToSave := Table.IndexFieldNames;
  Table.IndexFieldNames := IndexFieldNames;
  UsesSaveIndexies;
  SaveIndexFieldNames.AddObject(IndexToSave, Table.MasterSource);
end;

procedure RestoreIndex(Table: TTable);
begin
  if (SaveIndexFieldNames <> nil) and (SaveIndexFieldNames.Count > 0) then
  begin
    try
      Table.IndexFieldNames :=
        SaveIndexFieldNames[SaveIndexFieldNames.Count - 1];
      Table.MasterSource :=
        TDataSource(SaveIndexFieldNames.Objects[SaveIndexFieldNames.Count - 1]);
    finally
      SaveIndexFieldNames.Delete(SaveIndexFieldNames.Count - 1);
      if SaveIndexFieldNames.Count = 0 then
        ReleaseSaveIndexies;
    end;
  end;
end;

procedure DeleteRange(Table: TTable; IndexFields: array of const;
  FieldValues: array of const);
var
  I: Integer;
  NewIndex: string;
begin
  NewIndex := '';
  for I := Low(IndexFields) to High(IndexFields) do begin
    NewIndex := NewIndex + TVarRec(IndexFields[I]).VString^;
    if I <> High(IndexFields) then
      NewIndex := NewIndex + ';';
  end;
  SetIndex(Table, NewIndex);
  try
    Table.SetRange(FieldValues, FieldValues);
    try
      while not Table.EOF do Table.Delete;
    finally
      Table.CancelRange;
    end;
  finally
    RestoreIndex(Table);
  end;
end;

procedure ReindexTable(Table: TTable);
var
  WasActive: Boolean;
  WasExclusive: Boolean;
begin
  with Table do begin
    WasActive := Active;
    WasExclusive := Exclusive;
    DisableControls;
    try
      if not (WasActive and WasExclusive) then Close;
      try
        Exclusive := True;
        Open;
        Check(dbiRegenIndexes(Handle));
      finally
        if not (WasActive and WasExclusive) then begin
          Close;
          Exclusive := WasExclusive;
          Active := WasActive;
        end;
      end;
    finally
      EnableControls;
    end;
  end;
end;

procedure PackTable(Table: TTable);
{ This routine copied and modified from demo unit TableEnh.pas
  from Borland Int. }
var
  { FCurProp holds information about the structure of the table }
  FCurProp: CurProps;
  { Specific information about the table structure, indexes, etc. }
  TblDesc: CRTblDesc;
  { Uses as a handle to the database }
  hDb: hDbiDB;
  { Path to the currently opened table }
  TablePath: array[0..dbiMaxPathLen] of Char;
  Exclusive: Boolean;
begin
  if not Table.Active then _DBError(SDataSetClosed);
  Check(DbiGetCursorProps(Table.Handle, FCurProp));
  if StrComp(FCurProp.szTableType, szParadox) = 0 then begin
    { Call DbiDoRestructure procedure if PARADOX table }
    hDb := nil;
    { Initialize the table descriptor }
    FillChar(TblDesc, SizeOf(CRTblDesc), 0);
    with TblDesc do begin
      { Place the table name in descriptor }
      StrPCopy(szTblName, Table.TableName);
      { Place the table type in descriptor }
      StrCopy(szTblType, FCurProp.szTableType);
      bPack := True;
      bProtected := FCurProp.bProtected;
    end;
    { Get the current table's directory. This is why the table MUST be
      opened until now }
    Check(DbiGetDirectory(Table.DBHandle, False, TablePath));
    { Close the table }
    Table.Close;
    try
      { NOW: since the DbiDoRestructure call needs a valid DB handle BUT the
        table cannot be opened, call DbiOpenDatabase to get a valid handle.
        Setting TTable.Active = False does not give you a valid handle }
      Check(DbiOpenDatabase(nil, szCFGDBSTANDARD, dbiReadWrite, dbiOpenExcl, nil,
        0, nil, nil, hDb));
      { Set the table's directory to the old directory }
      Check(DbiSetDirectory(hDb, TablePath));
      { Pack the PARADOX table }
      Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, False));
      { Close the temporary database handle }
      Check(DbiCloseDatabase(hDb));
    finally
      { Re-Open the table }
      Table.Open;
    end;
  end
  else if StrComp(FCurProp.szTableType, szDBase) = 0 then begin
    { Call DbiPackTable procedure if dBase table }
    Exclusive := Table.Exclusive;
    Table.Close;
    try
      Table.Exclusive := True;
      Table.Open;
      try
        Check(DbiPackTable(Table.DBHandle, Table.Handle, nil, nil, True));
      finally
        Table.Close;
      end;
    finally
      Table.Exclusive := Exclusive;
      Table.Open;
    end;
  end
  else DbiError(DBIERR_WRONGDRVTYPE);
end;

procedure FetchAllRecords(DataSet: TBDEDataSet);
begin
  with DataSet do
    if not EOF then begin
      CheckBrowseMode;
      Check(DbiSetToEnd(Handle));
      Check(DbiGetPriorRecord(Handle, dbiNoLock, nil, nil));
      CursorPosChanged;
      UpdateCursorPos;
    end;
end;

procedure BdeFlushBuffers;
var
  I, L: Integer;
{$IFDEF WIN32}
  Session: TSession;
  J: Integer;
{$ENDIF}
begin
{$IFDEF WIN32}
  for J := 0 to Sessions.Count - 1 do begin
    Session := Sessions[J];
    if not Session.Active then Continue;
{$ENDIF}
    for I := 0 to Session.DatabaseCount - 1 do begin
      with Session.Databases[I] do
        if Connected and not IsSQLBased then begin
          for L := 0 to DataSetCount - 1 do begin
            if DataSets[L].Active then
              DbiSaveChanges(DataSets[L].Handle);