Chip 2002 March/Chip_2002-03_cd1.bin/zkuste/delphi/kompon/d5/ADO.ZIP/src/AdoConnection.pas

Pascal/Delphi Source File | 2001-12-23 | 23.5 KB | 655 lines

unit AdoConnection;

interface

{$I Ado25.inc}

uses
  ActiveX, Classes, Graphics, OleServer, StdVCL,  Windows, Forms, SysUtils,
  Dialogs,
  Ado21Int, AdoConsts;

// *********************************************************************//
// The Class CoConnection provides a Create and CreateRemote method to
// create instances of the default interface _Connection exposed by
// the CoClass Connection. The functions are intended to be used by
// clients wishing to automate the CoClass objects exposed by the
// server of this typelibrary.
// *********************************************************************//

type
  IConnection = Connection;
  IProperties = Properties;
  IErrors = Errors;
  IError = Error;
  IRecordset = Recordset;
  IFields = Fields;
  IField = Field;
  ICommand = Command;
  IParameters = Parameters;
  IParameter = Parameter;

  TConnectionInfoMessage = procedure(Sender: TObject; var pError: OleVariant;
      var adStatus: OleVariant;  var pConnection: OleVariant) of object;
  TConnectionBeginTransComplete = procedure(Sender: TObject; TransactionLevel: Integer;
      var pError: OleVariant; var adStatus: OleVariant; var pConnection: OleVariant) of object;
  TConnectionCommitTransComplete = procedure(Sender: TObject; var pError: OleVariant;
      var adStatus: OleVariant; var pConnection: OleVariant) of object;
  TConnectionRollbackTransComplete = procedure(Sender: TObject; var pError: OleVariant;
      var adStatus: OleVariant; var pConnection: OleVariant) of object;
  TConnectionWillExecute = procedure(Sender: TObject; var Source: OleVariant;
      var CursorType: OleVariant;var LockType: OleVariant; var Options: OleVariant;
      var adStatus: OleVariant; var pCommand: OleVariant; var pRecordset: OleVariant;
      var pConnection: OleVariant) of object;
  TConnectionExecuteComplete = procedure(Sender: TObject; RecordsAffected: Integer;
      var pError: OleVariant; var adStatus: OleVariant; var pCommand: OleVariant;
      var pRecordset: OleVariant; var pConnection: OleVariant) of object;
  TConnectionWillConnect = procedure(Sender: TObject; var ConnectionString: OleVariant;
      var UserID: OleVariant; var Password: OleVariant; var Options: OleVariant;
      var adStatus: OleVariant; var pConnection: OleVariant) of object;
  TConnectionConnectComplete = procedure(Sender: TObject; var pError: OleVariant;
      var adStatus: OleVariant; var pConnection: OleVariant) of object;
  TConnectionDisconnect = procedure(Sender: TObject; var adStatus: OleVariant;
      var pConnection: OleVariant) of object;

  TTableType = (ttTable, ttSystemTable, ttView);
  TTableTypes = set of TTableType;


// *********************************************************************//
// OLE Server Proxy class declaration
// Server Object    : TConnection
// Help String      :
// Default Interface: _Connection
// Def. Intf. DISP? : No
// Event   Interface: ConnectionEvents
// TypeFlags        : (6) CanCreate Licensed
// *********************************************************************//
  TConnection = class(TOleServer)
  private
    FUserID: WideString;
    FPassword: WideString;
    FConnectOption: ConnectOptionEnum;
    FDefaultDatabase: WideString;

    FOnInfoMessage: TConnectionInfoMessage;
    FOnBeginTransComplete: TConnectionBeginTransComplete;
    FOnCommitTransComplete: TConnectionCommitTransComplete;
    FOnRollbackTransComplete: TConnectionRollbackTransComplete;
    FOnWillExecute: TConnectionWillExecute;
    FOnExecuteComplete: TConnectionExecuteComplete;
    FOnWillConnect: TConnectionWillConnect;
    FOnConnectComplete: TConnectionConnectComplete;
    FOnDisconnect: TConnectionDisconnect;
    FIntf:        IConnection;
    function      GetDefaultInterface: IConnection;
    function GetProperites: IProperties;
    function GetActive: boolean;
    procedure SetActive(const Value: boolean);
    function GetPassword: WideString;
    procedure SetPassword(const Value: WideString);
    function GetUserID: WideString;
    procedure SetUserID(const Value: WideString);
    function GetConnectOption: ConnectOptionEnum;
    procedure SetConnectOption(const Value: ConnectOptionEnum);
  protected
    procedure InitServerData; override;
    procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); override;
    function  Get_ConnectionString: WideString;
    procedure Set_ConnectionString(const pbstr: WideString);
    function  Get_CommandTimeout: Integer;
    procedure Set_CommandTimeout(plTimeout: Integer);
    function  Get_ConnectionTimeout: Integer;
    procedure Set_ConnectionTimeout(plTimeout: Integer);
    function  Get_Version: WideString;
    function  Get_Errors: IErrors;
    function  Get_DefaultDatabase: WideString;
    procedure Set_DefaultDatabase(const pbstr: WideString);
    function  Get_IsolationLevel: IsolationLevelEnum;
    procedure Set_IsolationLevel(Level: IsolationLevelEnum);
    function  Get_Attributes: Integer;
    procedure Set_Attributes(plAttr: Integer);
    function  Get_CursorLocation: CursorLocationEnum;
    procedure Set_CursorLocation(plCursorLoc: CursorLocationEnum);
    function  Get_Mode: ConnectModeEnum;
    procedure Set_Mode(plMode: ConnectModeEnum);
    function  Get_Provider: WideString;
    procedure Set_Provider(const pbstr: WideString);
    function  Get_State: Integer;
    procedure WaitForConnectComplete;
  public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;
    procedure Connect; override;
    procedure ConnectTo(svrIntf: IConnection);
    procedure Disconnect; override;
    procedure Close;
    function  Execute(const CommandText: WideString; out RecordsAffected: OleVariant;
                      Options: Integer): IRecordset;
    function  BeginTrans: Integer;
    procedure CommitTrans;
    procedure RollbackTrans;
    procedure Open(const ConnectionString: WideString; const UserID: WideString;
                   const Password: WideString; Options: Integer); overload;
    procedure Open(const UserID: WideString; const Password: WideString); overload;
    procedure Open; overload;
    function  OpenSchema(Schema: SchemaEnum): IRecordset; overload;
    function  OpenSchema(Schema: SchemaEnum; Restrictions: OleVariant): IRecordset; overload;
    function  OpenSchema(Schema: SchemaEnum; Restrictions: OleVariant; SchemaID: OleVariant): IRecordset; overload;
    procedure Cancel;
    procedure GetProcedureNames(Procs: TStrings);
    procedure GetTableNames(Tables: TStrings; TableTypes: TTableTypes); overload;
    procedure GetTableNames(Tables: TStrings); overload;
    procedure GetFieldNames(TableName: string; Fields: TStrings);
    property  Connection: IConnection read GetDefaultInterface;
    property Errors: IErrors read Get_Errors;
    property Properites: IProperties read GetProperites;
  published
    property Version: WideString read Get_Version;
    property State: integer read Get_State;
    property ConnectionString: WideString read Get_ConnectionString write Set_ConnectionString;
    property CommandTimeout: Integer read Get_CommandTimeout write Set_CommandTimeout;
    property ConnectionTimeout: Integer read Get_ConnectionTimeout write Set_ConnectionTimeout;
    property DefaultDatabase: WideString read Get_DefaultDatabase write Set_DefaultDatabase;
    property IsolationLevel: IsolationLevelEnum read Get_IsolationLevel write Set_IsolationLevel;
    property Attributes: Integer read Get_Attributes write Set_Attributes;
    property CursorLocation: CursorLocationEnum read Get_CursorLocation write Set_CursorLocation;
    property Mode: ConnectModeEnum read Get_Mode write Set_Mode;
    property Provider: WideString read Get_Provider write Set_Provider;
    //new properites
    property UserID: WideString read GetUserID write SetUserID;
    property Password: WideString read GetPassword write SetPassword;
    property ConnectOption: ConnectOptionEnum read GetConnectOption write SetConnectOption;
    property Active: boolean read GetActive write SetActive;

    property OnInfoMessage: TConnectionInfoMessage read FOnInfoMessage write FOnInfoMessage;
    property OnBeginTransComplete: TConnectionBeginTransComplete read FOnBeginTransComplete write FOnBeginTransComplete;
    property OnCommitTransComplete: TConnectionCommitTransComplete read FOnCommitTransComplete write FOnCommitTransComplete;
    property OnRollbackTransComplete: TConnectionRollbackTransComplete read FOnRollbackTransComplete write FOnRollbackTransComplete;
    property OnWillExecute: TConnectionWillExecute read FOnWillExecute write FOnWillExecute;
    property OnExecuteComplete: TConnectionExecuteComplete read FOnExecuteComplete write FOnExecuteComplete;
    property OnWillConnect: TConnectionWillConnect read FOnWillConnect write FOnWillConnect;
    property OnConnectComplete: TConnectionConnectComplete read FOnConnectComplete write FOnConnectComplete;
    property OnDisconnect: TConnectionDisconnect read FOnDisconnect write FOnDisconnect;
  end;

  EAdoError =Exception;


procedure DoAdoError(ErrMsg: string); overload;
procedure DoAdoError(Errors: IErrors); overload;
procedure DoAdoError(const Msg: string; const Args: array of const); overload;

implementation

uses ComObj;

const
  ConnStr = 'Provider=%s;Data Source=%s;User ID=%s;Password=%s;%s';


procedure DoAdoError(ErrMsg: string);
begin
  raise EAdoError.Create(ErrMsg);
end;

procedure DoAdoError(const Msg: string; const Args: array of const);
begin
  raise EAdoError.CreateFmt(Msg, Args);
end;

procedure DoAdoError(Errors: IErrors);
var ErrMsg: string;
    i: integer;
begin
  case Errors.Count of
    0: exit;
    1: ErrMsg:= 'Wyst╣pi│ b│╣d AD0:'#10+Format('%s.%s', [Errors[0].Source, Errors[0].Description]);
    else begin
      ErrMsg:= 'Wyst╣pi│y b│Ωdy AD0:'#10;
      for i:= 0 to Errors.Count-1 do
        ErrMsg:= ErrMsg+Format('%d: %s.%s'#10, [i+1, Errors[i].Source, Errors[i].Description]);
    end;
  end;
  DoAdoError(ErrMsg);
end;

procedure TConnection.InitServerData;
const
  CServerData: TServerData = (
    ClassID:   '{00000514-0000-0010-8000-00AA006D2EA4}';
    IntfIID:   '{00000550-0000-0010-8000-00AA006D2EA4}';
    EventIID:  '{00000400-0000-0010-8000-00AA006D2EA4}';
    LicenseKey: nil;
    Version: 500);
begin
  ServerData := @CServerData;
end;

procedure TConnection.Connect;
var
  punk: IUnknown;
begin
  if FIntf = nil then
  begin
    punk := GetServer;
    ConnectEvents(punk);
    Fintf:= punk as IConnection;
  end;
end;

procedure TConnection.ConnectTo(svrIntf: IConnection);
begin
  Disconnect;
  FIntf := svrIntf;
  ConnectEvents(FIntf);
end;

procedure TConnection.DisConnect;
begin
  if Fintf <> nil then
  begin
    DisconnectEvents(FIntf);
    FIntf := nil;
  end;
end;

function TConnection.GetDefaultInterface: IConnection;
begin
  if FIntf = nil then
    Connect;
  Assert(FIntf <> nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call ''Connect'' or ''ConnectTo'' before this operation');
  Result := FIntf;
end;

constructor TConnection.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  AutoConnect:= true;
end;

destructor TConnection.Destroy;
begin
  inherited Destroy;
end;

procedure TConnection.InvokeEvent(DispID: TDispID; var Params: TVariantArray);
begin
  case DispID of
    -1: Exit;  // DISPID_UNKNOWN
   0: if Assigned(FOnInfoMessage) then
            FOnInfoMessage(Self, Params[0] {const Error}, Params[1] {var EventStatusEnum}, Params[2] {const _Connection});
   1: if Assigned(FOnBeginTransComplete) then
            FOnBeginTransComplete(Self, Params[0] {Integer}, Params[1] {const Error}, Params[2] {var EventStatusEnum}, Params[3] {const _Connection});
   3: if Assigned(FOnCommitTransComplete) then
            FOnCommitTransComplete(Self, Params[0] {const Error}, Params[1] {var EventStatusEnum}, Params[2] {const _Connection});
   2: if Assigned(FOnRollbackTransComplete) then
            FOnRollbackTransComplete(Self, Params[0] {const Error}, Params[1] {var EventStatusEnum}, Params[2] {const _Connection});
   4: if Assigned(FOnWillExecute) then
            FOnWillExecute(Self, Params[0] {var WideString}, Params[1] {var CursorTypeEnum}, Params[2] {var LockTypeEnum}, Params[3] {var Integer}, Params[4] {var EventStatusEnum}, Params[5] {const _Command}, Params[6] {const _Recordset}, Params[7] {const _Connection});
   5: if Assigned(FOnExecuteComplete) then
            FOnExecuteComplete(Self, Params[0] {Integer}, Params[1] {const Error}, Params[2] {var EventStatusEnum}, Params[3] {const _Command}, Params[4] {const _Recordset}, Params[5] {const _Connection});
   6: if Assigned(FOnWillConnect) then
            FOnWillConnect(Self, Params[0] {var WideString}, Params[1] {var WideString}, Params[2] {var WideString}, Params[3] {var Integer}, Params[4] {var EventStatusEnum}, Params[5] {const _Connection});
   7: if Assigned(FOnConnectComplete) then
            FOnConnectComplete(Self, Params[0] {const Error}, Params[1] {var EventStatusEnum}, Params[2] {const _Connection});
   8: if Assigned(FOnDisconnect) then
            FOnDisconnect(Self, Params[0] {var EventStatusEnum}, Params[1] {const _Connection});
  end; {case DispID}
end;

function  TConnection.Get_ConnectionString: WideString;
begin
  Result := Connection.Get_ConnectionString;
end;

procedure TConnection.Set_ConnectionString(const pbstr: WideString);
begin
  if pbstr <> ConnectionString then begin
    Close;
    Connection.Set_ConnectionString(pbstr);
  end;
end;

function  TConnection.Get_CommandTimeout: Integer;
begin
  Result := Connection.Get_CommandTimeout;
end;

procedure TConnection.Set_CommandTimeout(plTimeout: Integer);
begin
  Connection.Set_CommandTimeout(plTimeout);
end;

function  TConnection.Get_ConnectionTimeout: Integer;
begin
  Result := Connection.Get_ConnectionTimeout;
end;

procedure TConnection.Set_ConnectionTimeout(plTimeout: Integer);
begin
  if ConnectionTimeout <> plTimeout then
  begin
    Close;
    Connection.Set_ConnectionTimeout(plTimeout);
  end;
end;

function  TConnection.Get_Version: WideString;
begin
  Result := Connection.Get_Version;
end;

function  TConnection.Get_Errors: IErrors;
begin
  Result := Connection.Get_Errors as IErrors;
end;

function  TConnection.Get_DefaultDatabase: WideString;
begin
  if Active then
  try
    Result := Connection.Get_DefaultDatabase;
  except
  end
  else
    Result := FDefaultDatabase;
end;

procedure TConnection.Set_DefaultDatabase(const pbstr: WideString);
begin
  if DefaultDatabase <> pbstr then
  begin
    FDefaultDatabase := pbstr;
    if Active then
      Connection.Set_DefaultDatabase(pbstr);
  end;
end;

function  TConnection.Get_IsolationLevel: IsolationLevelEnum;
begin
  Result := Connection.Get_IsolationLevel;
end;

procedure TConnection.Set_IsolationLevel(Level: IsolationLevelEnum);
begin
  if IsolationLevel <> Level then begin
    //Close;
    Connection.Set_IsolationLevel(Level);
  end;
end;

function  TConnection.Get_Attributes: Integer;
begin
  Result := Connection.Get_Attributes;
end;

procedure TConnection.Set_Attributes(plAttr: Integer);
begin
  if Attributes <> plAttr then begin
    //Close;
    Connection.Set_Attributes(plAttr);
  end;
end;

function  TConnection.Get_CursorLocation: CursorLocationEnum;
begin
  Result := Connection.Get_CursorLocation;
end;

procedure TConnection.Set_CursorLocation(plCursorLoc: CursorLocationEnum);
begin
  if CursorLocation <> plCursorLoc then begin
    //Close;
    Connection.Set_CursorLocation(plCursorLoc);
  end;
end;

function  TConnection.Get_Mode: ConnectModeEnum;
begin
  Result := Connection.Mode;
end;

procedure TConnection.Set_Mode(plMode: ConnectModeEnum);
begin
  if Mode <> plMode then begin
    Close;
    Connection.Mode:= plMode;
  end;
end;

function  TConnection.Get_Provider: WideString;
begin
  Result := Connection.Get_Provider;
end;

procedure TConnection.Set_Provider(const pbstr: WideString);
begin
  if Provider <> pbstr then
  begin
    Close;
    Connection.Set_Provider(pbstr);
    //InternalUpdateConnectionString;
  end;
end;
//------------------------------------------------------------------------------
function  TConnection.Get_State: Integer;
begin
  Result := Connection.Get_State;
end;
//------------------------------------------------------------------------------
function  TConnection.BeginTrans: Integer;
begin
  Result := Connection.BeginTrans;
end;
//------------------------------------------------------------------------------
procedure TConnection.CommitTrans;
begin
  Connection.CommitTrans;
end;
//------------------------------------------------------------------------------
procedure TConnection.RollbackTrans;
begin
  Connection.RollbackTrans;
end;
//------------------------------------------------------------------------------
procedure TConnection.Close;
begin
  if Active then
    if Assigned(Connection) then
    begin
      //while InTransaction do RollbackTrans;
      Connection.Close;
    end;
end;
//------------------------------------------------------------------------------
procedure TConnection.Open;
begin
  if not Active then begin
    if ConnectionString = '' then
      DoAdoError(emNoConnectionString);
    Open(ConnectionString, UserID, Password, ConnectOption);
  end;
end;
//------------------------------------------------------------------------------
procedure TConnection.Open(const UserID, Password: WideString);
begin
  Open(ConnectionString, UserID, Password, ConnectOption);
end;
//------------------------------------------------------------------------------
procedure TConnection.Open(const ConnectionString: WideString; const UserID: WideString;
                           const Password: WideString; Options: Integer);
begin
  Close;
  Connection.Open(ConnectionString, UserID, Password, Options);
  if DefaultDatabase <> '' then
    Connection.DefaultDatabase := FDefaultDatabase;
  FUserID:= UserID;
  FPassword:= FPassword;
  FConnectOption:= Options;
  Connection.DefaultDatabase:= FDefaultDatabase;
  WaitForConnectComplete;
end;
//------------------------------------------------------------------------------
function  TConnection.OpenSchema(Schema: SchemaEnum): IRecordset;
begin
  Result := OpenSchema(Schema, EmptyParam, EmptyParam);
end;
//------------------------------------------------------------------------------
function  TConnection.OpenSchema(Schema: SchemaEnum; Restrictions: OleVariant): IRecordset;
begin
  Result := OpenSchema(Schema, Restrictions, EmptyParam);
end;
//------------------------------------------------------------------------------
function  TConnection.OpenSchema(Schema: SchemaEnum; Restrictions: OleVariant; SchemaID: OleVariant): IRecordset;
begin
  Result := Connection.OpenSchema(Schema, Restrictions, SchemaID) as IRecordset;
end;
//------------------------------------------------------------------------------
function  TConnection.Execute(const CommandText: WideString; out RecordsAffected: OleVariant;
                              Options: Integer): IRecordset;
begin
  Result := Connection.Execute(CommandText, RecordsAffected, Options) as IRecordset;
end;
//------------------------------------------------------------------------------
procedure TConnection.Cancel;
begin
  Connection.Cancel;
end;
//------------------------------------------------------------------------------
function TConnection.GetProperites: IProperties;
begin
  result:= Connection.Properties as IProperties;
end;
//------------------------------------------------------------------------------
procedure TConnection.SetActive(const Value: boolean);
begin
  if Value then Open
  else Close;
end;
//------------------------------------------------------------------------------
function TConnection.GetActive: boolean;
begin
  WaitForConnectComplete;
  Result := Assigned(Connection)
    and ((adStateOpen and Connection.State) <> 0);
end;
//------------------------------------------------------------------------------
procedure TConnection.WaitForConnectComplete;
begin
  if Assigned(Connection) then
    while (Connection.State = adStateConnecting) do
      Application.ProcessMessages;
end;
//------------------------------------------------------------------------------
function TConnection.GetConnectOption: ConnectOptionEnum;
begin
  result:= FConnectOption;
end;
//------------------------------------------------------------------------------
procedure TConnection.SetConnectOption(const Value: ConnectOptionEnum);
begin
  if Value<>FConnectOption then begin
    Close;
    FConnectOption:= Value;
  end;
end;
//------------------------------------------------------------------------------
function TConnection.GetPassword: WideString;
begin
  result:= FPassword;
end;
//------------------------------------------------------------------------------
procedure TConnection.SetPassword(const Value: WideString);
begin
  if Value <> FPassword then begin
    Close;
    FPassword:= Value;
  end;
end;
//------------------------------------------------------------------------------
function TConnection.GetUserID: WideString;
begin
  result:= FUserID;
end;
//------------------------------------------------------------------------------
procedure TConnection.SetUserID(const Value: WideString);
begin
  if Value<>FUserID then begin
    Close;
    FUserID:= Value;
  end;
end;
//------------------------------------------------------------------------------
procedure TConnection.GetProcedureNames(Procs: TStrings);
var ProcField: IField;
    Rst: IRecordset;
begin
  if not Active then
    DoAdoError(emNoConnectionActive);
  Procs.Clear;
  Rst:= OpenSchema(adSchemaProcedures);
  try
    ProcField:= Rst.Fields['PROCEDURE_NAME'] as IField;
    Rst.MoveFirst;
    while not Rst.EOF do begin
      Procs.Add(ProcField.Value);
      Rst.MoveNext;
    end;
  finally
    Rst:= nil;
  end;
end;
//------------------------------------------------------------------------------
procedure TConnection.GetTableNames(Tables: TStrings; TableTypes: TTableTypes);
var TypeField, NameField: IField;
    TypeName: string;
    Rst: IRecordset;
begin
  if not Active then
    DoAdoError(emNoConnectionActive);
  Tables.Clear;
  Rst:= OpenSchema(adSchemaTables);
  try
    TypeField := Rst.Fields['TABLE_TYPE'] as IField;
    NameField := Rst.Fields['TABLE_NAME'] as IField;
    Tables.Clear;
    Rst.MoveFirst;
    while not Rst.EOF do begin
      TypeName := TypeField.Value;
      if ( (TypeName = 'TABLE') and (ttTable in TableTypes) )
         or ( (TypeName = 'SYSTEM TABLE') and (ttSystemTable in TableTypes))
         or ( (TypeName = 'VIEW') and (ttView in TableTypes) )  then
        Tables.Add(NameField.Value);
      Rst.MoveNext;
    end;
  finally
    Rst:= nil;
  end;
end;
//------------------------------------------------------------------------------
procedure TConnection.GetTableNames(Tables: TStrings);
begin
  GetTableNames(Tables, [ttTable, ttView]);
end;
//------------------------------------------------------------------------------
procedure TConnection.GetFieldNames(TableName: string; Fields: TStrings);
var Rst: IRecordset;
begin
  if not Active then
    DoAdoError(emNoConnectionActive);
  Fields.Clear;
  Rst := OpenSchema(adSchemaColumns, VarArrayOf([Null, Null, TableName]));
  try
    Fields.Clear;
    while not Rst.EOF do begin
      Fields.Add(Rst.Fields['COLUMN_NAME'].Value);
      Rst.MoveNext;
    end;
  finally
    Rst:= nil;
  end;
end;

end.