jvbdeutils.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: JvBdeUtils.PAS, released on 2002-07-04.

The Initial Developers of the Original Code are: Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 1997, 1998 Fedor Koshevnikov, Igor Pavluk and Serge Korolev
Copyright (c) 2001,2002 SGB Software
All Rights Reserved.

Contributor(s):
Burov Dmitry, translation of russian text.

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
-----------------------------------------------------------------------------}
// $Id: JvBdeUtils.pas,v 1.32 2005/02/17 10:19:59 marquardt Exp $

unit JvBdeUtils;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows, Bde, Classes, DB, DBTables,
  JvDBUtils;

type
  TJvDBLocate = class(TJvLocateObject)
  private
    function LocateCallback: Boolean;
    procedure RecordFilter(DataSet: TDataSet; var Accept: Boolean);
  protected
    function LocateFilter: Boolean; override;
    procedure CheckFieldType(Field: TField); override;
    function LocateKey: Boolean; override;
    function UseKey: Boolean; override;
    function FilterApplicable: Boolean; override;
  public
    destructor Destroy; override;
  end;

  TJvCloneDataset = 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;

  TJvCloneDbDataset = 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;

  TJvCloneTable = 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: TJvLocateObject;
procedure FetchAllRecords(DataSet: TBDEDataSet);
function TransActive(Database: TDatabase): Boolean;
function AsyncQrySupported(Database: TDatabase): Boolean;
function GetQuoteChar(Database: TDatabase): string;
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);

{ begin JvDBUtil }
{ ExecuteSQLScript executes SQL script }

procedure ExecuteSQLScript(Base: TDatabase; const Script: string; const Commit: TCommit; OnProgress: TJvDBProgressEvent; const UserData: Integer);

{ GetQueryResult executes SQL Query and returns Result as Variant }

function GetQueryResult(const DatabaseName, SQL: string): Variant;

{ GetStoredProcResult executes SQL stored procedure and returns
  value of ResultName parameters as Variant }

function GetStoredProcResult(const ADatabaseName, AStoredProcName: string; AParams: array of Variant;
  const AResultName: string): Variant;

{ StrFieldDesc returns field description of given FLDDesc record }

function StrFieldDesc(Field: FLDDesc): string;

function Var2Type(V: Variant; const VarType: Integer): Variant;

procedure CopyRecord(DataSet: TDataSet);

{ AddReference create reference for paradox table,
  RefField and MasterField are field numbers (first field has number 1)
  Tables allready must have indices for this fields }

procedure AddReference(Tbl: TTable; RefName: string; RefField: Word;
  MasterTable: string; MasterField: Word; ModOp, DelOp: RINTQual);

{ AddMasterPassword extracted from "bde.hlp" file }
procedure AddMasterPassword(Table: TTable; pswd: string);

procedure PackEncryptedTable(Table: TTable; pswd: string);

function EncodeQuotes(const S: string): string;

{*********************** from JvStrUtil unit ***********************}

function Cmp(const S1, S2: string): Boolean;

{ SubStr returns substring from string, S,
  separated with Separator string}

function SubStr(const S: string; const Index: Integer; const Separator: string): string;

{ SubStrEnd same to previous function but Index numerated
  from the end of string }

function SubStrEnd(const S: string; const Index: Integer; const Separator: string): string;

{ ReplaceString searches for all substrings, OldPattern,
  in a string, S, and replaces them with NewPattern }

function ReplaceString(S: string; const OldPattern, NewPattern: string): string;

{ GetXYByPos is same to previous function, but
  returns X position in line too}

procedure GetXYByPos(const S: string; const Pos: Integer; var X, Y: Integer);

{####################### from JvStrUtil unit #######################}

{ end JvDBUtil }

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvBdeUtils.pas,v $';
    Revision: '$Revision: 1.32 $';
    Date: '$Date: 2005/02/17 10:19:59 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  SysUtils, Registry, Forms, Controls, Dialogs, Consts, Math,
  IniFiles, DBConsts, BDEConst, DBCommon,
  {$IFDEF HAS_UNIT_VARIANTS}
  Variants,
  {$ENDIF HAS_UNIT_VARIANTS}
  {$IFDEF HAS_UNIT_RTLCONSTS}
  RTLConsts,
  {$ENDIF HAS_UNIT_RTLCONSTS}
  JvConsts, JvJVCLUtils, JvJCLUtils, JvTypes, JvResources;

{ Utility routines }

procedure DBError(const Ident: string);
begin
  DatabaseError(Ident);
end;

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;
  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;
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,
      Result));
    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;

function GetQuoteChar(Database: TDatabase): string;
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;

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 := True;
end;

function FieldLogicMap(FldType: TFieldType): Integer;
begin
  Result := FldTypeMap[FldType];
end;

function FieldSubtypeMap(FldType: TFieldType): Integer;
begin
  Result := FldSubtypeMap[FldType];
end;

{ 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;
  D: Double;
  Data: Longint;
  TimeStamp: TTimeStamp;
begin
  if Buffer = nil then
  begin
    Buffer := AllocMem(FldSize);
    Allocate := Buffer <> nil;
  end
  else
    Allocate := False;
  try
    case FldLogicType of
      fldZSTRING:
        AnsiToNative(Locale, Value, PChar(Buffer), FldSize);
      fldBYTES, fldVARBYTES:
        Move(Value[1], Buffer^, Min(Length(Value), FldSize));
      fldINT16, fldINT32, fldUINT16, fldINT64:
        begin
          if Value = '' then
            FillChar(Buffer^, FldSize, 0)
          else
          begin
            Val(Value, L, E);
            if E <> 0 then
              DatabaseErrorFmt(SInvalidIntegerValue, [Value, FldName]);
            Move(L, Buffer^, FldSize);
          end;
        end;
      fldBOOL:
        begin
          L := Length(Value);
          if L = 0 then
            B := False
          else
            B := Value[1] in ['Y', 'y', 'T', 't', '1'];
          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:
        begin
          if Value = '' then
            FillChar(Buffer^, FldSize, 0)
          else
          begin
            DateTime := StrToDate(Value);
            TimeStamp := DateTimeToTimeStamp(DateTime);
            Data := TimeStamp.Date;
            Move(Data, Buffer^, Min(FldSize, SizeOf(Data)));
          end;
        end;
      fldTIME:
        begin
          if Value = '' then
            FillChar(Buffer^, FldSize, 0)
          else
          begin
            DateTime := StrToTime(Value);
            TimeStamp := DateTimeToTimeStamp(DateTime);
            Data := TimeStamp.Time;
            Move(Data, Buffer^, Min(FldSize, SizeOf(Data)));
          end;
        end;
      fldTIMESTAMP:
        begin
          if Value = '' then
            FillChar(Buffer^, FldSize, 0)
          else
          begin
            DateTime := StrToDateTime(Value);
            TimeStamp := DateTimeToTimeStamp(DateTime);
            D := TimeStampToMSecs(DateTimeToTimeStamp(DateTime));
            Move(D, Buffer^, Min(FldSize, SizeOf(D)));
          end;
        end;
    else
      DbiError(DBIERR_INVALIDFLDTYPE);
    end;
  finally
    if Allocate then
      FreeMem(Buffer, FldSize);
  end;
end;

{ Execute Query routine }

procedure ExecuteQueryEx(const SessName, DbName, QueryText: string);
begin
  with TQuery.Create(Application) do
  try
    DatabaseName := DbName;
    SessionName := SessName;
    SQL.Add(QueryText);
    ExecSQL;
  finally
    Free;
  end;
end;

procedure ExecuteQuery(const DbName, QueryText: string);
begin
  ExecuteQueryEx('', DbName, QueryText);
end;

{ Database Login routine }

function LoginToDatabase(Database: TDatabase; OnLogin: TDatabaseLoginEvent): Boolean;
var
  EndLogin: Boolean;
begin
  Result := Database.Connected;
  if Result then
    Exit;
  Database.OnLogin := OnLogin;
  EndLogin := True;
  repeat
    try
      Database.Connected := True;
      EndLogin := True;
    except
      on E: EDbEngineError do
      begin
        EndLogin := (MessageDlg(E.Message + '. ' + RsRetryLogin,
          mtConfirmation, [mbYes, mbNo], 0) <> mrYes);
      end;
      on E: EDatabaseError do
      begin
        { User select "Cancel" in login dialog }
        MessageDlg(E.Message, mtError, [mbOk], 0);
      end;
    else
      raise;
    end;
  until EndLogin;
  Result := Database.Connected;
end;

{ ReportSmith runtime initialization routine }

procedure InitRSRUN(Database: TDatabase; const ConName: string;
  ConType: Integer; const ConServer: string);
const
  IniFileName = 'RPTSMITH.CON';
  scConNames = 'ConnectNamesSection';
  idConNames = 'ConnectNames';
  idType = 'Type';
  idServer = 'Server';
  idSQLDataFilePath = 'Database';
  idDataFilePath = 'DataFilePath';
  idSQLUserID = 'USERID';
var
  ParamList: TStringList;
  DBPath: string[127];
  TempStr, AppConName: string[127];
  UserName: string[30];
  ExeName: string[12];
  IniFile: TIniFile;
begin
  ParamList := TStringList.Create;
  try
    Database.Session.GetAliasParams(Database.AliasName, ParamList);
    if Database.IsSQLBased then
      DBPath := ParamList.Values['SERVER NAME']
    else
      DBPath := ParamList.Values['PATH'];
    UserName := ParamList.Values['USER NAME'];
  finally
    ParamList.Free;
  end;