frxadocomponents.pas

报表控件。FastReport 是非常强大的报表控件

{******************************************}
{                                          }
{             FastReport v3.0              }
{         ADO enduser components           }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxADOComponents;

interface

{$I frx.inc}

uses
  Windows, Classes, SysUtils, frxClass, frxCustomDB, DB, ADODB, ADOInt
{$IFDEF Delphi6}
, Variants
{$ENDIF}
{$IFDEF QBUILDER}
, fqbClass
{$ENDIF}
{$IFDEF FR_COM}
, VclCOM, ComObj, ComServ
, FastReport_TLB
{$ENDIF}
;

const
  CLASS_TfrxADODatabase: TGUID = '{4B15360C-223C-4F3E-A306-8E5C19E2EA98}';
  CLASS_TfrxADOTable: TGUID = '{75AE7A73-E752-4DE6-A326-9C18C8D753F4}';
  CLASS_TfrxADOQuery: TGUID = '{6B1A7A66-07F6-4B4C-A454-BAA59FC951FA}';


type
  TfrxADOComponents = class(TfrxDBComponents)
  private
    FDefaultDatabase: TADOConnection;
    FOldComponents: TfrxADOComponents;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetDescription: String; override;
  published
    property DefaultDatabase: TADOConnection read FDefaultDatabase write FDefaultDatabase;
  end;

{$IFDEF FR_COM}
  TfrxADODatabase = class(TfrxCustomDatabase, IfrxADODatabase)
{$ELSE}
  TfrxADODatabase = class(TfrxCustomDatabase)
{$ENDIF}
  private
    FDatabase: TADOConnection;
  protected
    procedure SetConnected(Value: Boolean); override;
    procedure SetDatabaseName(const Value: String); override;
    procedure SetLoginPrompt(Value: Boolean); override;
    function GetConnected: Boolean; override;
    function GetDatabaseName: String; override;
    function GetLoginPrompt: Boolean; override;
{$IFDEF FR_COM}
    function Get_ConnectionString(out Value: WideString): HResult; stdcall;
    function Set_ConnectionString(const Value: WideString): HResult; stdcall;
    function Get_LoginPrompt(out Value: WordBool): HResult; stdcall;
    function Set_LoginPrompt(Value: WordBool): HResult; stdcall;
    function Get_Connected(out Value: WordBool): HResult; stdcall;
    function Set_Connected(Value: WordBool): HResult; stdcall;
    function Get_ConnectionTimeout(out Value: Integer): HResult; stdcall;
    function Set_ConnectionTimeout(Value: Integer): HResult; stdcall;
    function Get_CommandTimeout(out Value: Integer): HResult; stdcall;
    function Set_CommandTimeout(Value: Integer): HResult; stdcall;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    class function GetDescription: String; override;
    procedure SetLogin(const Login, Password: String); override;
    property Database: TADOConnection read FDatabase;
  published
    property DatabaseName;
    property LoginPrompt;
    property Connected;
  end;

{$IFDEF FR_COM}
  TfrxADOTable = class(TfrxCustomTable, IfrxADOTable)
{$ELSE}
  TfrxADOTable = class(TfrxCustomTable)
{$ENDIF}
  private
    FDatabase: TfrxADODatabase;
    FTable: TADOTable;
    procedure SetDatabase(Value: TfrxADODatabase);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetMaster(const Value: TDataSource); override;
    procedure SetMasterFields(const Value: String); override;
    procedure SetIndexFieldNames(const Value: String); override;
    procedure SetIndexName(const Value: String); override;
    procedure SetTableName(const Value: String); override;
    function GetIndexFieldNames: String; override;
    function GetIndexName: String; override;
    function GetTableName: String; override;
{$IFDEF FR_COM}
    function Get_DataBase(out Value: IfrxADODatabase): HResult; stdcall;
    function Set_DataBase(const Value: IfrxADODatabase): HResult; stdcall;
    function Get_IndexName(out Value: WideString): HResult; stdcall;
    function Set_IndexName(const Value: WideString): HResult; stdcall;
    function Get_TableName(out Value: WideString): HResult; stdcall;
    function Set_TableName(const Value: WideString): HResult; stdcall;
    function Get_Name(out Value: WideString): HResult; stdcall;
    function Set_Name(const Value: WideString): HResult; stdcall;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    constructor DesignCreate(AOwner: TComponent; Flags: Word); override;
    class function GetDescription: String; override;
    procedure BeforeStartReport; override;
    property Table: TADOTable read FTable;
  published
    property Database: TfrxADODatabase read FDatabase write SetDatabase;
  end;

{$IFDEF FR_COM}
  TfrxADOQuery = class(TfrxCustomQuery, IfrxADOQuery)
{$ELSE}
  TfrxADOQuery = class(TfrxCustomQuery)
{$ENDIF}
  private
    FDatabase: TfrxADODatabase;
    FQuery: TADOQuery;
    FStrings: TStrings;
    FLock: Boolean;
    procedure SetDatabase(Value: TfrxADODatabase);
    function GetCommandTimeout: Integer;
    procedure SetCommandTimeout(const Value: Integer);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure OnChangeSQL(Sender: TObject); override;
    procedure SetMaster(const Value: TDataSource); override;
    procedure SetSQL(Value: TStrings); override;
    function GetSQL: TStrings; override;
{$IFDEF FR_COM}
    function Get_DataBase(out Value: IfrxADODatabase): HResult; stdcall;
    function Set_DataBase(const Value: IfrxADODatabase): HResult; stdcall;
    function Get_Query(out Value: WideString): HResult; stdcall;
    function Set_Query(const Value: WideString): HResult; stdcall;
    function Get_Name(out Value: WideString): HResult; stdcall;
    function Set_Name(const Value: WideString): HResult; stdcall;
    function ParamByName(const Name: WideString; out Param: IfrxParamItem): HResult; stdcall;
    function Get_CommandTimeout(out Value: Integer): HResult; stdcall;
    function Set_CommandTimeout(Value: Integer): HResult; stdcall;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    constructor DesignCreate(AOwner: TComponent; Flags: Word); override;
    destructor Destroy; override;
    class function GetDescription: String; override;
    procedure BeforeStartReport; override;
    procedure UpdateParams; override;
{$IFDEF QBUILDER}
    function QBEngine: TfqbEngine; override;
{$ENDIF}
    property Query: TADOQuery read FQuery;
  published
    property CommandTimeout: Integer read GetCommandTimeout write SetCommandTimeout;
    property Database: TfrxADODatabase read FDatabase write SetDatabase;
  end;

{$IFDEF QBUILDER}
  TfrxEngineADO = class(TfqbEngine)
  private
    FQuery: TADOQuery;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ReadTableList(ATableList: TStrings); override;
    procedure ReadFieldList(const ATableName: string; var AFieldList: TfqbFieldList); override;
    function ResultDataSet: TDataSet; override;
    procedure SetSQL(const Value: string); override;
  end;
{$ENDIF}

procedure frxParamsToTParameters(Query: TfrxCustomQuery; Params: TParameters);
procedure frxADOGetTableNames(conADO: TADOConnection; List: TStrings; SystemTables: Boolean);

var
  ADOComponents: TfrxADOComponents;


implementation

uses
  frxADORTTI,
{$IFNDEF NO_EDITORS}
  frxADOEditor,
{$ENDIF}
  frxDsgnIntf, frxRes;

type
  THackQuery = class(TADOQuery);


{ frxParamsToTParameters }

procedure frxParamsToTParameters(Query: TfrxCustomQuery; Params: TParameters);
var
  i: Integer;
  Item: TfrxParamItem;
begin
  for i := 0 to Params.Count - 1 do
    if Query.Params.IndexOf(Params[i].Name) <> -1 then
    begin
      Item := Query.Params[Query.Params.IndexOf(Params[i].Name)];
      Params[i].DataType := Item.DataType;
      Params[i].Attributes := [paNullable];
      if Trim(Item.Expression) <> '' then
        if not (Query.IsLoading or Query.IsDesigning) then
        begin
          Query.Report.CurObject := Query.Name;
          Item.Value := Query.Report.Calc(Item.Expression);
        end;
      Params[i].Value := Item.Value;
    end;
end;

procedure frxADOGetTableNames(conADO: TADOConnection; List: TStrings; SystemTables: Boolean);
var
  tbl: TADODataSet;
  s: string;
begin
  tbl := TADODataSet.Create(nil);
  List.Clear;
  try
    conADO.OpenSchema(siTables, EmptyParam, EmptyParam, tbl);
    tbl.First;
    while not tbl.Eof do
    begin
      s := Trim(tbl.FieldByName('TABLE_SCHEMA').AsString);
      if s <> '' then
        List.Add(s + '.' + tbl.FieldByName('TABLE_NAME').AsString)
      else
        List.Add(tbl.FieldByName('TABLE_NAME').AsString);
      tbl.Next;
    end;
  finally
    tbl.Free;
  end;
end;


{ TfrxDBComponents }

constructor TfrxADOComponents.Create(AOwner: TComponent);
begin
  inherited;
  FOldComponents := ADOComponents;
  ADOComponents := Self;
end;

destructor TfrxADOComponents.Destroy;
begin
  if ADOComponents = Self then
    ADOComponents := FOldComponents;
  inherited;
end;

function TfrxADOComponents.GetDescription: String;
begin
  Result := 'ADO';
end;


{ TfrxADODatabase }

constructor TfrxADODatabase.Create(AOwner: TComponent);
begin
  inherited;
  FDatabase := TADOConnection.Create(nil);
  Component := FDatabase;
end;

class function TfrxADODatabase.GetDescription: String;
begin
  Result := frxResources.Get('obADODB');
end;

function TfrxADODatabase.GetConnected: Boolean;
begin
  Result := FDatabase.Connected;
end;

function TfrxADODatabase.GetDatabaseName: String;
begin
  Result := FDatabase.ConnectionString;
end;

function TfrxADODatabase.GetLoginPrompt: Boolean;
begin
  Result := FDatabase.LoginPrompt;
end;

procedure TfrxADODatabase.SetConnected(Value: Boolean);
begin
  BeforeConnect(Value);
  FDatabase.Connected := Value;
end;

procedure TfrxADODatabase.SetDatabaseName(const Value: String);
begin
  FDatabase.ConnectionString := Value;
end;

procedure TfrxADODatabase.SetLoginPrompt(Value: Boolean);
begin
  FDatabase.LoginPrompt := Value;
end;

procedure TfrxADODatabase.SetLogin(const Login, Password: String);
var
  i, j: Integer;
  s: String;
begin
  s := DatabaseName;
  i := Pos('USER ID=', AnsiUppercase(s));
  if i <> 0 then
  begin
    for j := i to Length(s) do
      if s[j] = ';' then
        break;
    Delete(s, i, j - i);
    Insert('User ID=' + Login, s, i);
  end
  else
    s := s + ';User ID=' + Login;

  i := Pos('PASSWORD=', AnsiUppercase(s));
  if i <> 0 then
  begin
    for j := i to Length(s) do
      if s[j] = ';' then
        break;
    Delete(s, i, j - i);
    Insert('Password=' + Password, s, i);
  end
  else
    s := s + ';Password=' + Password;

  DatabaseName := s;
end;
{$IFDEF FR_COM}
function TfrxADODatabase.Get_ConnectionString(out Value: WideString): HResult;
begin
  Value := PChar(DatabaseName);
  Result := S_OK;
end;

function TfrxADODatabase.Set_ConnectionString(
  const Value: WideString): HResult; stdcall;
begin
  DatabaseName := Value;
  Result := S_OK;
end;

function TfrxADODatabase.Get_LoginPrompt(out Value: WordBool): HResult; stdcall;
begin
  Value := LoginPrompt;
  Result := S_OK;
end;

function TfrxADODatabase.Set_LoginPrompt(Value: WordBool): HResult; stdcall;
begin
  LoginPrompt := Value;
  Result := S_OK;
end;

function TfrxADODatabase.Get_Connected(out Value: WordBool): HResult; stdcall;
begin
  Value := Connected;
  Result := S_OK;
end;

function TfrxADODatabase.Set_Connected(Value: WordBool): HResult; stdcall;
begin
  Result := S_OK;
  try
    Connected := Value;
  except
    on E: EOleException do Result := E.ErrorCode;
  end;
end;

function TfrxADODatabase.Get_ConnectionTimeout(out Value: Integer): HResult; stdcall;
begin
  Value := FDatabase.ConnectionTimeout;
  Result := S_OK;
end;

function TfrxADODatabase.Set_ConnectionTimeout(Value: Integer): HResult; stdcall;
begin
  FDatabase.ConnectionTimeout := Value;
  Result := S_OK;
end;

function TfrxADODatabase.Get_CommandTimeout(out Value: Integer): HResult; stdcall;
begin
  Value := FDatabase.CommandTimeout;
  Result := S_OK;
end;

function TfrxADODatabase.Set_CommandTimeout(Value: Integer): HResult; stdcall;
begin
  FDatabase.CommandTimeout := Value;
  Result := S_OK;
end;
{$ENDIF}

{ TfrxADOTable }

constructor TfrxADOTable.Create(AOwner: TComponent);
begin
  FTable := TADOTable.Create(nil);
  DataSet := FTable;
  SetDatabase(nil);
  inherited;
end;

constructor TfrxADOTable.DesignCreate(AOwner: TComponent; Flags: Word);
var