frxcross.pas

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

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

unit frxCross;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, Controls, Graphics, Forms, frxCrossMatrix,
  frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF}
{$IFDEF FR_COM}
, FastReport_TLB
, ActiveX
{$ENDIF};

type
  TfrxCrossObject = class(TComponent);  // fake component

  TfrxPrintCellEvent = type String;
  TfrxPrintHeaderEvent = type String;
  TfrxCalcWidthEvent = type String;
  TfrxCalcHeightEvent = type String;
  TfrxOnPrintCellEvent = procedure (Memo: TfrxCustomMemoView;
    RowIndex, ColumnIndex, CellIndex: Integer;
    const RowValues, ColumnValues, Value: Variant) of object;
  TfrxOnPrintHeaderEvent = procedure (Memo: TfrxCustomMemoView;
    const HeaderIndexes, HeaderValues, Value: Variant) of object;
  TfrxOnCalcWidthEvent = procedure (ColumnIndex: Integer;
    const ColumnValues: Variant; var Width: Extended) of object;
  TfrxOnCalcHeightEvent = procedure (RowIndex: Integer;
    const RowValues: Variant; var Height: Extended) of object;

{$IFDEF FR_COM}
  TfrxCustomCrossView = class(TfrxView, IfrxCustomCrossView)
{$ELSE}
  TfrxCustomCrossView = class(TfrxView)
{$ENDIF}
  private
    FMatrix: TfrxCrossMatrix;
    FBorder: Boolean;
    FCellFields: TStrings;
    FCellLevels: Integer;
    FClearBeforePrint: Boolean;
    FColumnBands: TList;
    FColumnFields: TStrings;
    FColumnLevels: Integer;
    FDefHeight: Integer;
    FDotMatrix: Boolean;
    FDownThenAcross: Boolean;
    FGapX: Integer;
    FGapY: Integer;
    FMaxWidth: Integer;
    FMinWidth: Integer;
    FOnCalcHeight: TfrxCalcHeightEvent;                  { script event }
    FOnCalcWidth: TfrxCalcWidthEvent;                    { script event }
    FOnPrintCell: TfrxPrintCellEvent;                    { script event }
    FOnPrintColumnHeader: TfrxPrintHeaderEvent;          { script event }
    FOnPrintRowHeader: TfrxPrintHeaderEvent;             { script event }
    FOnBeforeCalcHeight: TfrxOnCalcHeightEvent;          { Delphi event }
    FOnBeforeCalcWidth: TfrxOnCalcWidthEvent;            { Delphi event }
    FOnBeforePrintCell: TfrxOnPrintCellEvent;            { Delphi event }
    FOnBeforePrintColumnHeader: TfrxOnPrintHeaderEvent;  { Delphi event }
    FOnBeforePrintRowHeader: TfrxOnPrintHeaderEvent;     { Delphi event }
    FPlainCells: Boolean;
    FRowBands: TList;
    FRowFields: TStrings;
    FRowLevels: Integer;
    FRepeatHeaders: Boolean;
    FShowColumnHeader: Boolean;
    FShowRowHeader: Boolean;
    procedure AddSourceObjects;
    procedure BuildColumnBands;
    procedure BuildRowBands;
    procedure ClearColumnBands;
    procedure ClearRowBands;
    procedure CorrectDMPBounds(Memo: TfrxCustomMemoView);
    procedure DoCalcHeight(Row: Integer; var Height: Extended);
    procedure DoCalcWidth(Column: Integer; var Width: Extended);
    procedure DoOnCell(Memo: TfrxCustomMemoView; Row, Column, Cell: Integer;
      const Value: Variant);
    procedure DoOnColumnHeader(Memo: TfrxCustomMemoView; Header: TfrxCrossHeader);
    procedure DoOnRowHeader(Memo: TfrxCustomMemoView; Header: TfrxCrossHeader);
    procedure ReadMemos(Stream: TStream);
    procedure RenderMatrix;
    procedure SetCellFields(const Value: TStrings);
    procedure SetCellFunctions(Index: Integer; const Value: TfrxCrossFunction);
    procedure SetColumnFields(const Value: TStrings);
    procedure SetColumnSort(Index: Integer; Value: TfrxCrossSortOrder);
    procedure SetRowFields(const Value: TStrings);
    procedure SetRowSort(Index: Integer; Value: TfrxCrossSortOrder);
    procedure SetShowColumnTotal(const Value: Boolean);
    procedure SetShowRowTotal(const Value: Boolean);
    procedure SetupOriginalComponent(Obj1, Obj2: TfrxComponent);
    procedure WriteMemos(Stream: TStream);
    function CreateMemo(Parent: TfrxComponent): TfrxCustomMemoView;
    function GetCellFunctions(Index: Integer): TfrxCrossFunction;
    function GetCellMemos(Index: Integer): TfrxCustomMemoView;
    function GetColumnMemos(Index: Integer): TfrxCustomMemoView;
    function GetColumnSort(Index: Integer): TfrxCrossSortOrder;
    function GetColumnTotalMemos(Index: Integer): TfrxCustomMemoView;
    function GetRowMemos(Index: Integer): TfrxCustomMemoView;
    function GetRowSort(Index: Integer): TfrxCrossSortOrder;
    function GetRowTotalMemos(Index: Integer): TfrxCustomMemoView;
    function GetShowColumnTotal: Boolean;
    function GetShowRowTotal: Boolean;
    procedure SetDotMatrix(const Value: Boolean);
    procedure SetPlainCells(const Value: Boolean);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure SetCellLevels(const Value: Integer); virtual;
    procedure SetColumnLevels(const Value: Integer); virtual;
    procedure SetRowLevels(const Value: Integer); virtual;
{$IFDEF FR_COM}
    function Get_CellFields(out Value: WideString): HResult; stdcall;
    function Set_CellFields(const Value: WideString): HResult; stdcall;
    function Get_CellFunctions(Index: Integer; out Value: frxCrossFunction): HResult; stdcall;
    function Set_CellFunctions(Index: Integer; Value: frxCrossFunction): HResult; stdcall;
    function Get_CellMemos(Index: Integer; out Value: IfrxCustomMemoView): HResult; stdcall;
    function Get_ColumnFields(out Value: WideString): HResult; stdcall;
    function Set_ColumnFields(const Value: WideString): HResult; stdcall;
    function Get_ColumnMemos(Index: Integer; out Value: IfrxCustomMemoView): HResult; stdcall;
    function Get_ColumnSort(Index: Integer; out Value: frxCrossSortOrder): HResult; stdcall;
    function Set_ColumnSort(Index: Integer; Value: frxCrossSortOrder): HResult; stdcall;
    function Get_ColumnTotalMemos(Index: Integer; out Value: IfrxCustomMemoView): HResult; stdcall;
    function Get_RowFields(out Value: WideString): HResult; stdcall;
    function Set_RowFields(const Value: WideString): HResult; stdcall;
    function Get_RowMemos(Index: Integer; out Value: IfrxCustomMemoView): HResult; stdcall;
    function Get_RowSort(Index: Integer; out Value: frxCrossSortOrder): HResult; stdcall;
    function Set_RowSort(Index: Integer; Value: frxCrossSortOrder): HResult; stdcall;
    function Get_RowTotalMemos(Index: Integer; out Value: IfrxCustomMemoView): HResult; stdcall;
    function Get_MaxWidth(out Value: Integer): HResult; stdcall;
    function Set_MaxWidth(Value: Integer): HResult; stdcall;
    function Get_MinWidth(out Value: Integer): HResult; stdcall;
    function Set_MinWidth(Value: Integer): HResult; stdcall;
    function AddValues(Rows: PSafeArray; Columns: PSafeArray; Cells: PSafeArray): HResult; stdcall;
    function Get_GapX(out Value: Integer): HResult; stdcall;
    function Set_GapX(Value: Integer): HResult; stdcall;
    function Get_GapY(out Value: Integer): HResult; stdcall;
    function Set_GapY(Value: Integer): HResult; stdcall;
    function Get_PlainCells(out Value: WordBool): HResult; stdcall;
    function Set_PlainCells(Value: WordBool): HResult; stdcall;
    function Get_DownThenAcross(out Value: WordBool): HResult; stdcall;
    function Set_DownThenAcross(Value: WordBool): HResult; stdcall;
    function Get_RepeatHeaders(out Value: WordBool): HResult; stdcall;
    function Set_RepeatHeaders(Value: WordBool): HResult; stdcall;
    function Get_ShowColumnHeader(out Value: WordBool): HResult; stdcall;
    function Set_ShowColumnHeader(Value: WordBool): HResult; stdcall;
    function Get_ShowColumnTotal(out Value: WordBool): HResult; stdcall;
    function Set_ShowColumnTotal(Value: WordBool): HResult; stdcall;
    function Get_ShowRowHeader(out Value: WordBool): HResult; stdcall;
    function Set_ShowRowHeader(Value: WordBool): HResult; stdcall;
    function Get_ShowRowTotal(out Value: WordBool): HResult; stdcall;
    function Set_ShowRowTotal(Value: WordBool): HResult; stdcall;
    function AddValuesVB6(Rows: OleVariant; Columns: OleVariant; Cells: OleVariant): HResult; stdcall;
{$ENDIF}
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Draw(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended); override;
    procedure BeforePrint; override;
    procedure GetData; override;
    procedure BeginMatrix;
    procedure EndMatrix;
    procedure FillMatrix; virtual;
    procedure AddValue(const Rows, Columns, Cells: array of Variant);

    function ColCount: Integer;
    function RowCount: Integer;
    function IsCrossValid: Boolean; virtual;
    function IsGrandTotalColumn(Index: Integer): Boolean;
    function IsGrandTotalRow(Index: Integer): Boolean;
    function IsTotalColumn(Index: Integer): Boolean;
    function IsTotalRow(Index: Integer): Boolean;
    function RowHeaderWidth: Extended;
    function ColumnHeaderHeight: Extended;

    property Matrix: TfrxCrossMatrix read FMatrix;
    property CellFields: TStrings read FCellFields write SetCellFields;
    property CellFunctions[Index: Integer]: TfrxCrossFunction read GetCellFunctions
      write SetCellFunctions;
    property CellMemos[Index: Integer]: TfrxCustomMemoView read GetCellMemos;
    property ColumnFields: TStrings read FColumnFields write SetColumnFields;
    property ColumnMemos[Index: Integer]: TfrxCustomMemoView read GetColumnMemos;
    property ColumnSort[Index: Integer]: TfrxCrossSortOrder read GetColumnSort
      write SetColumnSort;
    property ColumnTotalMemos[Index: Integer]: TfrxCustomMemoView read GetColumnTotalMemos;
    property ClearBeforePrint: Boolean read FClearBeforePrint write FClearBeforePrint;
    property DotMatrix: Boolean read FDotMatrix;
    property RowFields: TStrings read FRowFields write SetRowFields;
    property RowMemos[Index: Integer]: TfrxCustomMemoView read GetRowMemos;
    property RowSort[Index: Integer]: TfrxCrossSortOrder read GetRowSort
      write SetRowSort;
    property RowTotalMemos[Index: Integer]: TfrxCustomMemoView read GetRowTotalMemos;
    property OnBeforeCalcHeight: TfrxOnCalcHeightEvent
      read FOnBeforeCalcHeight write FOnBeforeCalcHeight;
    property OnBeforeCalcWidth: TfrxOnCalcWidthEvent
      read FOnBeforeCalcWidth write FOnBeforeCalcWidth;
    property OnBeforePrintCell: TfrxOnPrintCellEvent
      read FOnBeforePrintCell write FOnBeforePrintCell;
    property OnBeforePrintColumnHeader: TfrxOnPrintHeaderEvent
      read FOnBeforePrintColumnHeader write FOnBeforePrintColumnHeader;
    property OnBeforePrintRowHeader: TfrxOnPrintHeaderEvent
      read FOnBeforePrintRowHeader write FOnBeforePrintRowHeader;
  published
    property Border: Boolean read FBorder write FBorder default True;
    property CellLevels: Integer read FCellLevels write SetCellLevels default 1;
    property ColumnLevels: Integer read FColumnLevels write SetColumnLevels default 1;
    property DefHeight: Integer read FDefHeight write FDefHeight default 0;
    property DownThenAcross: Boolean read FDownThenAcross write FDownThenAcross;
    property GapX: Integer read FGapX write FGapX default 3;
    property GapY: Integer read FGapY write FGapY default 3;
    property MaxWidth: Integer read FMaxWidth write FMaxWidth default 200;
    property MinWidth: Integer read FMinWidth write FMinWidth default 0;
    property PlainCells: Boolean read FPlainCells write SetPlainCells default False;
    property RepeatHeaders: Boolean read FRepeatHeaders write FRepeatHeaders default True;
    property RowLevels: Integer read FRowLevels write SetRowLevels default 1;
    property ShowColumnHeader: Boolean read FShowColumnHeader write FShowColumnHeader
      default True;
    property ShowColumnTotal: Boolean read GetShowColumnTotal write SetShowColumnTotal
      default True;
    property ShowRowHeader: Boolean read FShowRowHeader write FShowRowHeader
      default True;
    property ShowRowTotal: Boolean read GetShowRowTotal write SetShowRowTotal
      default True;
    property OnCalcHeight: TfrxCalcHeightEvent read FOnCalcHeight write FOnCalcHeight;
    property OnCalcWidth: TfrxCalcWidthEvent read FOnCalcWidth write FOnCalcWidth;
    property OnPrintCell: TfrxPrintCellEvent read FOnPrintCell write FOnPrintCell;
    property OnPrintColumnHeader: TfrxPrintHeaderEvent
      read FOnPrintColumnHeader write FOnPrintColumnHeader;
    property OnPrintRowHeader: TfrxPrintHeaderEvent
      read FOnPrintRowHeader write FOnPrintRowHeader;
  end;

{$IFDEF FR_COM}
  TfrxCrossView = class(TfrxCustomCrossView, IfrxCrossView)
{$ELSE}
  TfrxCrossView = class(TfrxCustomCrossView)
{$ENDIF}
  protected
    procedure SetCellLevels(const Value: Integer); override;
    procedure SetColumnLevels(const Value: Integer); override;
    procedure SetRowLevels(const Value: Integer); override;
  public
    class function GetDescription: String; override;
    function IsCrossValid: Boolean; override;
  published
  end;

{$IFDEF FR_COM}
  TfrxDBCrossView = class(TfrxCustomCrossView, IfrxDBCrossView)
{$ELSE}
  TfrxDBCrossView = class(TfrxCustomCrossView)
{$ENDIF}
  private
  public
    class function GetDescription: String; override;
    function IsCrossValid: Boolean; override;
    procedure FillMatrix; override;
  published
    property CellFields;
    property ColumnFields;
    property DataSet;
    property DataSetName;
    property RowFields;
  end;


implementation

uses
{$IFNDEF NO_EDITORS}
  frxCrossEditor,
{$ENDIF}  
  frxCrossRTTI, frxDsgnIntf, frxXML, frxUtils, frxXMLSerializer, frxRes,
  frxDMPClass;

type
  THackComponent = class(TfrxComponent);
  THackMemoView = class(TfrxCustomMemoView);


{ TfrxCustomCrossView }

constructor TfrxCustomCrossView.Create(AOwner: TComponent);
begin
  inherited;
  Frame.Typ := [ftLeft, ftRight, ftTop, ftBottom];
  Font.Name := 'Tahoma';
  Font.Size := 8;
  Color := clSilver;

  FMatrix := TfrxCrossMatrix.Create;
  FCellFields := TStringList.Create;
  FColumnFields := TStringList.Create;
  FRowFields := TStringList.Create;
  FColumnBands := TList.Create;
  FRowBands := TList.Create;
  FBorder := True;
  FGapX := 3;
  FGapY := 3;
  FMaxWidth := 200;
  CellLevels := 1;
  ColumnLevels := 1;
  RowLevels := 1;
  FRepeatHeaders := True;
  FShowColumnHeader := True;
  FShowRowHeader := True;
  FMatrix.OnCalcHeight := DoCalcHeight;
  FMatrix.OnCalcWidth := DoCalcWidth;
  if Page is TfrxDMPPage then
    SetDotMatrix(True);
  FClearBeforePrint := True;
end;

destructor TfrxCustomCrossView.Destroy;
begin
  FMatrix.Free;
  FCellFields.Free;
  FColumnFields.Free;
  FRowFields.Free;
  ClearColumnBands;
  ClearRowBands;
  FColumnBands.Free;
  FRowBands.Free;
  inherited;
end;

procedure TfrxCustomCrossView.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineBinaryProperty('Memos', ReadMemos, WriteMemos, True);
end;

procedure TfrxCustomCrossView.ReadMemos(Stream: TStream);
var
  x: TfrxXMLDocument;
  i: Integer;

  procedure GetItem(m: TfrxCustomMemoView; const Name: String; Index: Integer);
  var
    xs: TfrxXMLSerializer;
    Item: TfrxXMLItem;
  begin
    Item := x.Root.FindItem(Name);
    if Index >= Item.Count then Exit;
    Item := Item[Index];

    xs := TfrxXMLSerializer.Create(nil);
    m.Frame.Typ := [];
    m.Font.Style := [];
    m.HAlign := haLeft;
    m.VAlign := vaTop;
    xs.ReadRootComponent(m, Item);
    xs.Free;
  end;

  function GetItem1(const Name: String; Index: Integer): TfrxCrossFunction;
  var
    Item: TfrxXMLItem;
  begin
    Result := cfNone;
    Item := x.Root.FindItem(Name);
    if Index >= Item.Count then Exit;
    Item := Item[Index];
    Result := TfrxCrossFunction(StrToInt(Item.Text));
  end;

  function GetItem2(const Name: String; Index: Integer): TfrxCrossSortOrder;
  var
    Item: TfrxXMLItem;
  begin
    Result := soAscending;
    Item := x.Root.FindItem(Name);
    if Index >= Item.Count then Exit;
    Item := Item[Index];
    Result := TfrxCrossSortOrder(StrToInt(Item.Text));
  end;

begin
  x := TfrxXMLDocument.Create;
  try
    x.LoadFromStream(Stream);

    for i := 0 to CROSS_DIM_SIZE - 1 do
    begin
      GetItem(CellMemos[i], 'cellmemos', i);
      GetItem(ColumnMemos[i], 'columnmemos', i);
      GetItem(ColumnTotalMemos[i], 'columntotalmemos', i);
      GetItem(RowMemos[i], 'rowmemos', i);
      GetItem(RowTotalMemos[i], 'rowtotalmemos', i);
      CellFunctions[i] := GetItem1('cellfunctions', i);
      ColumnSort[i] := GetItem2('columnsort', i);
      RowSort[i] := GetItem2('rowsort', i);
    end;

  finally
    x.Free;
  end;
end;

procedure TfrxCustomCrossView.WriteMemos(Stream: TStream);
var
  x: TfrxXMLDocument;
  i: Integer;

  procedure AddItem(m: TfrxCustomMemoView; const Name: String);
  var
    xs: TfrxXMLSerializer;
  begin
    xs := TfrxXMLSerializer.Create(nil);
    xs.WriteRootComponent(m, False, x.Root.FindItem(Name).Add);
    xs.Free;
  end;

  procedure AddItem1(f: TfrxCrossFunction; const Name: String);
  var
    Item: TfrxXMLItem;
  begin
    Item := x.Root.FindItem(Name);