bdeutils.pas

rxlib2.75控件包

{*******************************************************}
{                                                       }
{         Delphi VCL Extensions (RX)                    }
{                                                       }
{         Copyright (c) 1995, 1996 AO ROSNO             }
{         Copyright (c) 1997, 1998 Master-Bank          }
{                                                       }
{*******************************************************}

unit BdeUtils;

{$I RX.INC}
{$W-,R-,B-,N+,P+}

interface

uses SysUtils, Windows, Bde, Registry, RTLConsts, Classes, DB, DBTables,
  IniFiles, DBUtils;

type
{$IFNDEF WIN32}
  TLocateFilter = (lfTree, lfCallback);
{$ENDIF}

{$IFNDEF RX_D3}
  TBDEDataSet = TDataSet;
{$ENDIF}

{$IFNDEF RX_D5}
  TDatabaseLoginEvent = TLoginEvent;
{$ENDIF}

  TDBLocate = class(TLocateObject)
  private
{$IFNDEF WIN32}
    FFilterHandle: HDBIFilter;
    FTree: PChar;
    FTreeSize: Integer;
    FFilterKind: TLocateFilter;
    procedure ActivateFilter;
    procedure DeactivateFilter;
    procedure DropFilter;
    procedure CheckFilterKind;
    procedure ChangeBookmark;
    procedure BuildFilterHeader(var Rec);
    procedure BuildFilterTree;
    procedure FreeTree;
    function RecordFilter(RecBuf: Pointer; RecNo: Longint): Smallint;
      {$IFDEF WIN32} stdcall; {$ENDIF}
{$ELSE}
    function LocateCallback: Boolean;
    procedure RecordFilter(DataSet: TDataSet; var Accept: Boolean);
{$ENDIF WIN32}
  protected
{$IFDEF WIN32}
    function LocateFilter: Boolean; override;
{$ELSE}
    procedure ActiveChanged; override;
    function LocateFilter: Boolean; override;
{$ENDIF WIN32}
    procedure CheckFieldType(Field: TField); override;
    function LocateKey: Boolean; override;
    function UseKey: Boolean; override;
    function FilterApplicable: Boolean; override;
  public
    destructor Destroy; override;
  end;

{ TCloneDataset }

  TCloneDataset = class(TBDEDataSet)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ TCloneDbDataset }

  TCloneDbDataset = class(TDBDataSet)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    procedure InitFromDataSet(Source: TDBDataSet; Reset: Boolean);
    property SourceHandle: HDBICur read FSourceHandle write SetSourceHandle;
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ TCloneTable }

  TCloneTable = class(TTable)
  private
    FSourceHandle: HDBICur;
    FReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure SetSourceHandle(ASourceHandle: HDBICur);
  protected
    function CreateHandle: HDBICur; override;
  public
    procedure InitFromTable(SourceTable: TTable; Reset: Boolean);
  published
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
  end;

{ Utility routines }

function CreateDbLocate: TLocateObject;
{$IFNDEF WIN32}
function CheckOpen(Status: DBIResult): Boolean;
{$ENDIF}
procedure FetchAllRecords(DataSet: TBDEDataSet);
function TransActive(Database: TDatabase): Boolean;
function AsyncQrySupported(Database: TDatabase): Boolean;
{$IFDEF WIN32}
function GetQuoteChar(Database: TDatabase): string;
{$ENDIF}
procedure ExecuteQuery(const DbName, QueryText: string);
procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
procedure BdeTranslate(Locale: TLocale; Source, Dest: PChar; ToOem: Boolean);
function FieldLogicMap(FldType: TFieldType): Integer;
function FieldSubtypeMap(FldType: TFieldType): Integer;
procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  FldSize: Word; const FldName, Value: string; Buffer: Pointer);
function GetAliasPath(const AliasName: string): string;
function IsDirectory(const DatabaseName: string): Boolean;
function GetBdeDirectory: string;
function BdeErrorMsg(ErrorCode: DBIResult): string;
function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
function DataSetFindValue(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
function DataSetFindLike(ADataSet: TBDEDataSet; const Value,
  FieldName: string): Boolean;
function DataSetRecNo(DataSet: TDataSet): Longint;
function DataSetRecordCount(DataSet: TDataSet): Longint;
function DataSetPositionStr(DataSet: TDataSet): string;
procedure DataSetShowDeleted(DataSet: TBDEDataSet; Show: Boolean);
function CurrentRecordDeleted(DataSet: TBDEDataSet): Boolean;
function IsFilterApplicable(DataSet: TDataSet): Boolean;
function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1,
  Bookmark2: TBookmark): Integer;
function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
procedure SetIndex(Table: TTable; const IndexFieldNames: string);
procedure RestoreIndex(Table: TTable);
procedure DeleteRange(Table: TTable; IndexFields: array of const;
  FieldValues: array of const);
procedure PackTable(Table: TTable);
procedure ReindexTable(Table: TTable);
procedure BdeFlushBuffers;
function GetNativeHandle(Database: TDatabase; Buffer: Pointer;
  BufSize: Integer): Pointer;
procedure ToggleDebugLayer(Active: Boolean; const DebugFile: string);
procedure DbNotSupported;

{ Export/import DataSet routines }

procedure ExportDataSet(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; MaxRecordCount: Longint);
procedure ExportDataSetEx(Source: TBDEDataSet; DestTable: TTable;
  TableType: TTableType; const AsciiCharSet: string;
  AsciiDelimited: Boolean; AsciiDelimiter, AsciiSeparator: Char;
  MaxRecordCount: Longint);
procedure ImportDataSet(Source: TBDEDataSet; DestTable: TTable;
  MaxRecordCount: Longint; Mappings: TStrings; Mode: TBatchMode);

{ ReportSmith initialization }

procedure InitRSRUN(Database: TDatabase; const ConName: string;
  ConType: Integer; const ConServer: string);

implementation

uses Forms, Controls, Dialogs, Consts, DBConsts, RXDConst, VCLUtils,
  FileUtil, AppUtils, rxStrUtils, MaxMin, {$IFNDEF WIN32} Str16, {$ENDIF}
  {$IFDEF RX_D3} BDEConst, DBCommon, {$ENDIF} DateUtil;

{ Utility routines }

{$IFDEF RX_D5}
procedure DBError(Ident: Word);
begin
  DatabaseError(LoadStr(Ident));
end;
{$ENDIF}

function IsBookmarkStable(DataSet: TBDEDataSet): Boolean;
var
  Props: CURProps;
begin
  with DataSet do
    Result := Active and (DbiGetCursorProps(Handle, Props) = DBIERR_NONE) and
      Props.bBookMarkStable;
end;

function SetToBookmark(ADataSet: TDataSet; ABookmark: TBookmark): Boolean;
begin
  Result := False;
{$IFDEF RX_D3}
  with ADataSet do
    if Active and (ABookmark <> nil) and not (Bof and Eof) and
      BookmarkValid(ABookmark) then
    try
      ADataSet.GotoBookmark(ABookmark);
      Result := True;
    except
    end;
{$ELSE}
  with TBDEDataSet(ADataSet) do
    if Active and (ABookmark <> nil) and not (Bof and Eof) then
      if DbiSetToBookmark(Handle, ABookmark) = DBIERR_NONE then
      try
        Resync([rmExact, rmCenter]);
        Result := True;
      except
      end;
{$ENDIF}
end;

function BookmarksCompare(DataSet: TBDEDataSet; Bookmark1, Bookmark2: TBookmark): Integer;
const
  RetCodes: array[Boolean, Boolean] of ShortInt =
    ((2, CMPLess), (CMPGtr, CMPEql));
begin
  Result := RetCodes[Bookmark1 = nil, Bookmark2 = nil];
  if Result = 2 then begin
    Check(DbiCompareBookmarks(DataSet.Handle, Bookmark1, Bookmark2, 
      {$IFDEF WIN32} Result)); {$ELSE} Word(Result))); {$ENDIF}
    if Result = CMPKeyEql then Result := CMPEql;
  end;
end;

function DBGetIntProp(const Handle: Pointer; PropName: Longint): Longint;
var
  Length: Word;
  Value: Longint;
begin
  Value := 0;
  Check(DbiGetProp(HDBIObj(Handle), PropName, @Value, SizeOf(Value), Length));
  Result := Value;
end;

{$IFDEF WIN32}
function GetQuoteChar(Database: TDatabase): string;
{$IFNDEF RX_D3}
const
  dbQUOTECHAR = $0404000A;
{$ENDIF}
var
  Q: Char;
  Len: Word;
begin
  Result := '';
  if Database.IsSQLBased then begin
    Q := #0;
    DbiGetProp(HDBIObj(Database.Handle), dbQUOTECHAR, @Q, SizeOf(Q), Len);
    if Q <> #0 then Result := Q;
  end
  else Result := '"';
end;
{$ENDIF}

function AsyncQrySupported(Database: TDatabase): Boolean;
begin
  Result := False;
  if Database.Connected then
    if Database.IsSQLBased then
      try
        Result := BOOL(DBGetIntProp(Database.Handle, dbASYNCSUPPORT));
      except
      end
    else Result := {$IFDEF WIN32} True {$ELSE} False {$ENDIF};
end;

function FieldLogicMap(FldType: TFieldType): Integer;
{$IFNDEF RX_D3}
{$IFDEF VER80}
const
  FldTypeMap: array[TFieldType] of Integer = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
{$ELSE}
const
  FldTypeMap: array[TFieldType] of Integer = (
    fldUNKNOWN, fldZSTRING, fldINT16, fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldINT32, fldBLOB, fldBLOB, fldBLOB, fldBLOB, fldBLOB,
    fldBLOB, fldBLOB);
{$ENDIF}
{$ENDIF}
begin
  Result := FldTypeMap[FldType];
end;

function FieldSubtypeMap(FldType: TFieldType): Integer;
{$IFNDEF RX_D3}
{$IFDEF VER80}
const
  FldSubtypeMap: array[TFieldType] of Integer = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstBINARY,
    fldstMEMO, fldstGRAPHIC);
{$ELSE}
const
  FldSubtypeMap: array[TFieldType] of Integer = (
    0, 0, 0, 0, 0, 0, 0, fldstMONEY, 0, 0, 0, 0, 0, 0, fldstAUTOINC,
    fldstBINARY, fldstMEMO, fldstGRAPHIC, fldstFMTMEMO, fldstOLEOBJ,
    fldstDBSOLEOBJ, fldstTYPEDBINARY);
{$ENDIF}
{$ENDIF}
begin
  Result := FldSubtypeMap[FldType];
end;

{$IFNDEF WIN32}
function CheckOpen(Status: DBIResult): Boolean;
begin
  case Status of
    DBIERR_NONE:
      Result := True;
    DBIERR_NOTSUFFTABLERIGHTS:
      begin
        if not Session.GetPassword then DbiError(Status);
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;
{$ENDIF}

{ Routine for convert string to IDAPI logical field type }

procedure ConvertStringToLogicType(Locale: TLocale; FldLogicType: Integer;
  FldSize: Word; const FldName, Value: string; Buffer: Pointer);
var
  Allocate: Boolean;
  BCD: FMTBcd;
  E: Integer;
  L: Longint;
  B: WordBool;
  DateTime: TDateTime;
  DtData: TDateTime;
  D: Double absolute DtData;
  Data: Longint absolute DtData;
{$IFDEF WIN32}
  TimeStamp: TTimeStamp;
{$ENDIF}
begin
  if Buffer = nil then begin
    Buffer := AllocMem(FldSize);
    Allocate := Buffer <> nil;
  end
  else Allocate := False;
  try
    case FldLogicType of
      fldZSTRING:
        begin
          AnsiToNative(Locale, Value, PChar(Buffer), FldSize);
        end;
      fldBYTES, fldVARBYTES:
        begin
          Move(Value[1], Buffer^, Min(Length(Value), FldSize));
        end;
      fldINT16, fldINT32, fldUINT16:
        begin
          if Value = '' then FillChar(Buffer^, FldSize, 0)
          else begin
            Val(Value, L, E);
            if E <> 0 then
{$IFDEF RX_D3}
              DatabaseErrorFmt(SInvalidIntegerValue, [Value, FldName]);
{$ELSE}
              DBErrorFmt(SInvalidIntegerValue, [Value, FldName]);
{$ENDIF}
            Move(L, Buffer^, FldSize);
          end;
        end;
      fldBOOL:
        begin
          L := Length(Value);
          if L = 0 then B := False
          else begin
            if Value[1] in ['Y', 'y', 'T', 't', '1'] then B := True
            else B := False;
          end;
          Move(B, Buffer^, SizeOf(WordBool));
        end;
      fldFLOAT, fldBCD:
        begin
          if Value = '' then FillChar(Buffer^, FldSize, 0)
          else begin
            D := StrToFloat(Value);
            if FldLogicType <> fldBCD then Move(D, Buffer^, SizeOf(Double))
            else begin
              DbiBcdFromFloat(D, 32, FldSize, BCD);
              Move(BCD, Buffer^, SizeOf(BCD));
            end;
          end;
        end;
      fldDATE, fldTIME, fldTIMESTAMP:
        begin
          if Value = '' then Data := Trunc(NullDate)
          else begin
            case FldLogicType of
              fldDATE:
                begin
                  DateTime := StrToDate(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  Data := TimeStamp.Date;
{$ELSE}
                  Data := Trunc(DateTime);
{$ENDIF}
                end;
              fldTIME:
                begin
                  DateTime := StrToTime(Value);
{$IFDEF WIN32}
                  TimeStamp := DateTimeToTimeStamp(DateTime);
                  Data := TimeStamp.Time;
{$ELSE}
                  Data := Round(Frac(DateTime) * MSecsPerDay);
{$ENDIF}
                end;
              fldTIMESTAMP: