frxcustomdb.pas

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

{******************************************}
{                                          }
{             FastReport v3.0              }
{      Custom TDataSet-based classes       }
{        for enduser DB components         }
{                                          }
{         Copyright (c) 1998-2006          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxCustomDB;

interface

{$I frx.inc}

uses
  Windows, Classes, SysUtils, DB, frxClass, frxDBSet, DBCtrls
{$IFDEF Delphi6}
, Variants
{$ENDIF}
{$IFDEF QBUILDER}
, fqbClass
{$ENDIF}
{$IFDEF FR_COM}
, FastReport_TLB
{$ENDIF};


type
  TfrxCustomDataset = class(TfrxDBDataSet)
  private
    FDBConnected: Boolean;
    FDataSource: TDataSource;
    FMaster: TfrxDBDataSet;
    FMasterFields: String;
    procedure SetActive(Value: Boolean);
    procedure SetFilter(const Value: String);
    procedure SetFiltered(Value: Boolean);
    function GetActive: Boolean;
    function GetFields: TFields;
    function GetFilter: String;
    function GetFiltered: Boolean;
    procedure InternalSetMaster(const Value: TfrxDBDataSet);
    procedure InternalSetMasterFields(const Value: String);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetParent(AParent: TfrxComponent); override;
    procedure SetUserName(const Value: String); override;
    procedure SetMaster(const Value: TDataSource); virtual;
    procedure SetMasterFields(const Value: String); virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure OnPaste; override;
    property DBConnected: Boolean read FDBConnected write FDBConnected;
    property Fields: TFields read GetFields;
    property MasterFields: String read FMasterFields write InternalSetMasterFields;
    property Active: Boolean read GetActive write SetActive default False;
  published
    property Filter: String read GetFilter write SetFilter;
    property Filtered: Boolean read GetFiltered write SetFiltered default False;
    property Master: TfrxDBDataSet read FMaster write InternalSetMaster;
  end;

  TfrxCustomTable = class(TfrxCustomDataset)
  protected
    function GetIndexFieldNames: String; virtual;
    function GetIndexName: String; virtual;
    function GetTableName: String; virtual;
    procedure SetIndexFieldNames(const Value: String); virtual;
    procedure SetIndexName(const Value: String); virtual;
    procedure SetTableName(const Value: String); virtual;
  published
    property MasterFields;
    property TableName: String read GetTableName write SetTableName;
    property IndexName: String read GetIndexName write SetIndexName;
    property IndexFieldNames: String read GetIndexFieldNames write SetIndexFieldNames;
  end;

{$IFDEF FR_COM}
  TfrxParamItem = class(TCollectionItem, IUnknown, IfrxParamItem)
  private
    FRefCount: Integer;
{$ELSE}
  TfrxParamItem = class(TCollectionItem)
  private
{$ENDIF}
    FDataType: TFieldType;
    FExpression: String;
    FName: String;
    FValue: Variant;
{$IFDEF FR_COM}
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { IfrxParamItem }
    function Get_Name(out Value: WideString): HResult; stdcall;
    function Set_Name(const Value: WideString): HResult; stdcall;
    function Get_Value(out Value: OleVariant): HResult; stdcall;
    function Set_Value(Value: OleVariant): HResult; stdcall;
    function Get_Expression(out Value: WideString): HResult; stdcall;
    function Set_Expression(const Value: WideString): HResult; stdcall;
    function Get_FieldType(out Value: frxFieldType): HResult; stdcall;
    function Set_FieldType(Value: frxFieldType): HResult; stdcall;
{$ENDIF}
  public
    procedure Assign(Source: TPersistent); override;
    property Value: Variant read FValue write FValue;
  published
    property Name: String read FName write FName;
    property DataType: TFieldType read FDataType write FDataType;
    property Expression: String read FExpression write FExpression;
  end;

  TfrxParams = class(TCollection)
  private
    function GetParam(Index: Integer): TfrxParamItem;
  public
    constructor Create;
    function Add: TfrxParamItem;
    function Find(const Name: String): TfrxParamItem;
    function IndexOf(const Name: String): Integer;
    procedure UpdateParams(const SQL: String);
    property Items[Index: Integer]: TfrxParamItem read GetParam; default;
  end;

  TfrxCustomQuery = class(TfrxCustomDataset)
  private
    FParams: TfrxParams;
    FSaveOnBeforeOpen: TDataSetNotifyEvent;
    FSaveOnChange: TNotifyEvent;
    FSQLSchema: String;
    procedure ReadData(Reader: TReader);
    procedure SetParams(Value: TfrxParams);
    procedure WriteData(Writer: TWriter);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure OnBeforeOpen(DataSet: TDataSet); virtual;
    procedure OnChangeSQL(Sender: TObject); virtual;
    procedure SetSQL(Value: TStrings); virtual;
    function GetSQL: TStrings; virtual;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure UpdateParams; virtual;
    function ParamByName(const Value: String): TfrxParamItem;
{$IFDEF QBUILDER}
    function QBEngine: TfqbEngine; virtual;
{$ENDIF}
  published
    property Params: TfrxParams read FParams write SetParams;
    property SQL: TStrings read GetSQL write SetSQL;
    property SQLSchema: String read FSQLSchema write FSQLSchema;
  end;

  TfrxDBLookupComboBox = class(TfrxDialogControl)
  private
    FDataSet: TfrxDBDataSet;
    FDataSetName: String;
    FDataSource: TDataSource;
    FDBLookupComboBox: TDBLookupComboBox;
    function GetDataSetName: String;
    function GetKeyField: String;
    function GetKeyValue: Variant;
    function GetListField: String;
    function GetText: String;
    procedure SetDataSet(const Value: TfrxDBDataSet);
    procedure SetDataSetName(const Value: String);
    procedure SetKeyField(Value: String);
    procedure SetKeyValue(const Value: Variant);
    procedure SetListField(Value: String);
    procedure UpdateDataSet;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    class function GetDescription: String; override;
    procedure BeforeStartReport; override;
    property DBLookupComboBox: TDBLookupComboBox read FDBLookupComboBox;
    property KeyValue: Variant read GetKeyValue write SetKeyValue;
    property Text: String read GetText;
  published
    property ListField: String read GetListField write SetListField;
    property DataSet: TfrxDBDataSet read FDataSet write SetDataSet;
    property DataSetName: String read GetDataSetName write SetDataSetName;
    property KeyField: String read GetKeyField write SetKeyField;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


procedure frxParamsToTParams(Query: TfrxCustomQuery; Params: TParams);


implementation

uses
{$IFNDEF NO_EDITORS}
  frxCustomDBEditor,
{$ENDIF}
  frxCustomDBRTTI, frxDsgnIntf, frxUtils, frxFormUtils, frxRes;


{ TfrxParamItem }

procedure TfrxParamItem.Assign(Source: TPersistent);
begin
  if Source is TfrxParamItem then
  begin
    FName := TfrxParamItem(Source).Name;
    FDataType := TfrxParamItem(Source).DataType;
    FExpression := TfrxParamItem(Source).Expression;
    FValue := TfrxParamItem(Source).Value;
  end;
end;

{$IFDEF FR_COM}
function TfrxParamItem.QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
begin
  if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
end;

function TfrxParamItem._AddRef: Integer; stdcall;
begin
  Result := InterlockedIncrement(FRefCount);
end;

function TfrxParamItem._Release: Integer; stdcall;
begin
  Result := InterlockedDecrement(FRefCount);
//  if Result = 0 then Destroy;
end;

function TfrxParamItem.Get_Name(out Value: WideString): HResult; stdcall;
begin
  Value := Name;
  Result := S_OK;
end;

function TfrxParamItem.Set_Name(const Value: WideString): HResult; stdcall;
begin
  Name := Value;
  Result := S_OK;
end;

function TfrxParamItem.Get_Value(out Value: OleVariant): HResult; stdcall;
begin
  Value := Self.Value;
  Result := S_OK;
end;

function TfrxParamItem.Set_Value(Value: OleVariant): HResult; stdcall;
begin
  Self.Value := Value;
  Result := S_OK;
end;

function TfrxParamItem.Get_Expression(out Value: WideString): HResult; stdcall;
begin
  Value := Expression;
  Result := S_OK;
end;

function TfrxParamItem.Set_Expression(const Value: WideString): HResult; stdcall;
begin
  Expression := Value;
  Result := S_OK;
end;

function TfrxParamItem.Get_FieldType(out Value: frxFieldType): HResult; stdcall;
begin
  Value := OleVariant(DataType);
  Result := S_OK;
end;

function TfrxParamItem.Set_FieldType(Value: frxFieldType): HResult; stdcall;
begin
  DataType := TFieldType(Value);
  Result := S_OK;
end;
{$ENDIF}

{ TfrxParams }

constructor TfrxParams.Create;
begin
  inherited Create(TfrxParamItem);
end;

function TfrxParams.Add: TfrxParamItem;
begin
  Result := TfrxParamItem(inherited Add);
end;

function TfrxParams.GetParam(Index: Integer): TfrxParamItem;
begin
  Result := TfrxParamItem(inherited Items[Index]);
end;

function TfrxParams.Find(const Name: String): TfrxParamItem;
var
  i: Integer;
begin
  i := IndexOf(Name);
  if i <> -1 then
    Result := Items[i] else
    Result := nil;
end;

function TfrxParams.IndexOf(const Name: String): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to Count - 1 do
    if CompareText(Items[i].Name, Name) = 0 then
    begin
      Result := i;
      break;
    end;
end;

procedure TfrxParams.UpdateParams(const SQL: String);
var
  i, j: Integer;
  QParams: TParams;
  NewParams: TfrxParams;
begin
  { parse query params }
  QParams := TParams.Create;
  QParams.ParseSQL(SQL, True);

  { create new TfrxParams object and copy all params to it }
  NewParams := TfrxParams.Create;
  for i := 0 to QParams.Count - 1 do
    with NewParams.Add do
    begin
      Name := QParams[i].Name;
      j := IndexOf(Name);
      if j <> -1 then
      begin
        DataType := Items[j].DataType;
        Value := Items[j].Value;
        Expression := Items[j].Expression;
      end;
    end;

  Assign(NewParams);
  QParams.Free;
  NewParams.Free;
end;


{ TfrxCustomDataset }

constructor TfrxCustomDataset.Create(AOwner: TComponent);
begin
  Component := Dataset;
  inherited;
  CloseDataSource := True;
  FDataSource := TDataSource.Create(nil);
  SetMaster(FDataSource);
end;

destructor TfrxCustomDataset.Destroy;
begin
  FDataSource.Free;
  inherited;
end;

procedure TfrxCustomDataset.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited;
  if Operation = opRemove then
    if AComponent = FMaster then
      Master := nil
end;

procedure TfrxCustomDataset.SetParent(AParent: TfrxComponent);
begin
  inherited;
  if (AParent <> nil) and (Report <> nil) then
  begin
    if IsDesigning and (Report.DataSets.Find(Self) = nil) then