frxcrossmatrix.pas

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

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

unit frxCrossMatrix;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, Controls, Graphics, frxClass, frxDMPClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};

const
  CROSS_DIM_SIZE = 16;

type
  { the record represents one cell of cross matrix }
  PfrCrossCell = ^TfrxCrossCell;
  TfrxCrossCell = packed record
    Value: Variant;
    Count: Integer;
    Next: PfrCrossCell;    { pointer to the next value in the same cell }
  end;

  TfrxCrossSortOrder = (soAscending, soDescending, soNone);
  TfrxCrossFunction = (cfNone, cfSum, cfMin, cfMax, cfAvg, cfCount);
  TfrxVariantArray = array of Variant;
  TfrxMemoArray = array[0..CROSS_DIM_SIZE - 1] of TfrxCustomMemoView;
  TfrxSortArray = array[0..CROSS_DIM_SIZE - 1] of TfrxCrossSortOrder;

  { the base class for column/row item. Contains Indexes array that
    identifies a column/row }
  TfrxIndexItem = class(TCollectionItem)
  private
    FIndexes: TfrxVariantArray;
  public
    destructor Destroy; override;
    property Indexes: TfrxVariantArray read FIndexes write FIndexes;
  end;

  { the base collection for column/row items. Contains methods for working
    with Indexes and sorting them }
  TfrxIndexCollection = class(TCollection)
  private
    FIndexesCount: Integer;
    FSortOrder: TfrxSortArray;
    function GetItems(Index: Integer): TfrxIndexItem;
  public
    function Find(const Indexes: array of Variant; var Index: Integer): Boolean;
    function InsertItem(Index: Integer; const Indexes: array of Variant): TfrxIndexItem; virtual;
    property Items[Index: Integer]: TfrxIndexItem read GetItems; default;
  end;

  { the class representing a single row item }
  TfrxCrossRow = class(TfrxIndexItem)
  private
    FCellLevels: Integer;
    FCells: TList;
    procedure CreateCell(Index: Integer);
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    function GetCell(Index: Integer): PfrCrossCell;
    function GetCellValue(Index1, Index2: Integer): Variant;
    procedure SetCellValue(Index1, Index2: Integer; const Value: Variant);
  end;

  { the class representing row items }
  TfrxCrossRows = class(TfrxIndexCollection)
  private
    FCellLevels: Integer;
    function GetItems(Index: Integer): TfrxCrossRow;
  public
    constructor Create;
    function InsertItem(Index: Integer; const Indexes: array of Variant): TfrxIndexItem; override;
    function Row(const Indexes: array of Variant): TfrxCrossRow;
    property Items[Index: Integer]: TfrxCrossRow read GetItems; default;
  end;

  { the class representing a single column item }
  TfrxCrossColumn = class(TfrxIndexItem)
  private
    FCellIndex: Integer;
  public
    property CellIndex: Integer read FCellIndex write FCellIndex;
  end;

  { the class representing column items }
  TfrxCrossColumns = class(TfrxIndexCollection)
  private
    function GetItems(Index: Integer): TfrxCrossColumn;
  public
    constructor Create;
    function Column(const Indexes: array of Variant): TfrxCrossColumn;
    function InsertItem(Index: Integer; const Indexes: array of Variant): TfrxIndexItem; override;
    property Items[Index: Integer]: TfrxCrossColumn read GetItems; default;
  end;

  { TfrxCrossHeader represents one cell of a cross header. The cell has a value,
    position, size and list of subcells }
  TfrxCrossHeader = class(TObject)
  private
    FBounds: TfrxRect;                 { bounds of the cell }
    FMemos: TfrxMemoArray;
    FTotalMemos: TfrxMemoArray;
    FCounts: TfrxVariantArray;
    FCellLevels: Integer;
    FFuncValues: TfrxVariantArray;
    FIsTotal: Boolean;                 { is this cell a total cell }
    FItems: TList;                     { subcells }
    FLevelsCount: Integer;             { number of header levels }
    FMemo: TfrxCustomMemoView;         { memo for this cell }
    FParent: TfrxCrossHeader;          { parent of the cell }
    FSize: TfrxPoint;
    FValue: Variant;                   { value (text) of the cell }
    FVisible: Boolean;                 { visibility of the cell }
    FCellSizes: array[0..CROSS_DIM_SIZE - 1] of Extended;

    procedure AddFuncValues(const Values, Counts: array of Variant;
      const CellFunctions: array of TfrxCrossFunction);
    procedure AddValues(const Values: array of Variant);
    procedure Reset(const CellFunctions: array of TfrxCrossFunction);
    procedure CalcSizes(MaxWidth, MinWidth: Integer);
    procedure CalcBounds; virtual; abstract;

    function GetCount: Integer;
    function GetItems(Index: Integer): TfrxCrossHeader;
    function GetLevel: Integer;
    function GetHeight: Extended;
    function GetWidth: Extended;
    function GetCellSizes(Index: Integer): Extended;
    procedure SetCellSizes(Index: Integer; const Value: Extended);
  public
    constructor Create(CellLevels: Integer);
    destructor Destroy; override;

    function AllItems: TList;
    function Find(Value: Variant): Integer;
    function GetIndexes: Variant;
    function GetValues: Variant;
    function TerminalItems: TList;

    property Bounds: TfrxRect read FBounds write FBounds;
    property CellSizes[Index: Integer]: Extended read GetCellSizes write SetCellSizes;
    property Count: Integer read GetCount;
    property Height: Extended read GetHeight;
    property IsTotal: Boolean read FIsTotal;
    property Items[Index: Integer]: TfrxCrossHeader read GetItems; default;
    property Level: Integer read GetLevel;
    property Memo: TfrxCustomMemoView read FMemo;
    property Parent: TfrxCrossHeader read FParent;
    property Value: Variant read FValue write FValue;
    property Visible: Boolean read FVisible write FVisible;
    property Width: Extended read GetWidth;
  end;

  { the cross columns }
  TfrxCrossColumnHeader = class(TfrxCrossHeader)
  private
    procedure CalcBounds; override;
  end;

  { the cross rows }
  TfrxCrossRowHeader = class(TfrxCrossHeader)
  private
    procedure CalcBounds; override;
  end;

  TfrxCrossCalcSizeEvent = procedure (Index: Integer; var Size: Extended) of object;

  { the cross matrix. Contains cross body (matrix), row and column headers }
  TfrxCrossMatrix = class(TObject)
  private
    FCellFunctions: array[0..CROSS_DIM_SIZE - 1] of TfrxCrossFunction;
    FCellLevels: Integer;
    FColumnHeader: TfrxCrossColumnHeader;
    FColumns: TfrxCrossColumns;
    FColumnSort: TfrxSortArray;
    FDefHeight: Integer;
    FGapX: Integer;
    FGapY: Integer;
    FMaxWidth: Integer;
    FMinWidth: Integer;
    FNoColumns: Boolean;
    FNoRows: Boolean;
    FPlainCells: Boolean;
    FRowHeader: TfrxCrossRowHeader;
    FRows: TfrxCrossRows;
    FRowSort: TfrxSortArray;

    FCellMemos: TfrxMemoArray;
    FColumnMemos: TfrxMemoArray;
    FColumnTotalMemos: TfrxMemoArray;
    FRowMemos: TfrxMemoArray;
    FRowTotalMemos: TfrxMemoArray;
    FOnCalcHeight: TfrxCrossCalcSizeEvent;
    FOnCalcWidth: TfrxCrossCalcSizeEvent;
    procedure CalcTotal(Header: TfrxCrossHeader; Source: TfrxIndexCollection);
    procedure CreateHeader(Header: TfrxCrossHeader; Source: TfrxIndexCollection;
      const Totals: TfrxMemoArray; TotalVisible: Boolean);
    procedure SetCellFunctions(Index: Integer; const Value: TfrxCrossFunction);
    procedure SetColumnSort(Index: Integer; Value: TfrxCrossSortOrder);
    procedure SetRowSort(Index: Integer; Value: TfrxCrossSortOrder);
    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;
  public
    constructor Create;
    destructor Destroy; override;

    procedure Init(RowLevels, ColumnLevels, CellLevels: Integer);
    procedure InitMemos(DotMatrix: Boolean);
    procedure Clear;
    procedure ClearMemos;

    procedure AddValue(const Rows, Columns, Cells: array of Variant);
    function GetValue(ARow, AColumn, ACell: Integer): Variant;
    function GetColumnIndexes(AColumn: Integer): Variant;
    function GetRowIndexes(ARow: Integer): Variant;

    procedure CreateHeaders;
    procedure CalcTotals;
    procedure CalcBounds;

    function ColCount: Integer;
    function RowCount: Integer;
    function IsGrandTotalColumn(Index: Integer): Boolean;
    function IsGrandTotalRow(Index: Integer): Boolean;
    function IsTotalColumn(Index: Integer): Boolean;
    function IsTotalRow(Index: Integer): Boolean;
    function GetDrawSize: TfrxPoint;

    property ColumnHeader: TfrxCrossColumnHeader read FColumnHeader;
    property RowHeader: TfrxCrossRowHeader read FRowHeader;
    property NoColumns: Boolean read FNoColumns;
    property NoRows: Boolean read FNoRows;

    property CellFunctions[Index: Integer]: TfrxCrossFunction read GetCellFunctions
      write SetCellFunctions;
    property CellMemos[Index: Integer]: TfrxCustomMemoView read GetCellMemos;
    property ColumnMemos[Index: Integer]: TfrxCustomMemoView read GetColumnMemos;
    property ColumnSort[Index: Integer]: TfrxCrossSortOrder read GetColumnSort
      write SetColumnSort;
    property ColumnTotalMemos[Index: Integer]: TfrxCustomMemoView read GetColumnTotalMemos;
    property DefHeight: Integer read FDefHeight write FDefHeight;
    property GapX: Integer read FGapX write FGapX;
    property GapY: Integer read FGapY write FGapY;
    property MaxWidth: Integer read FMaxWidth write FMaxWidth;
    property MinWidth: Integer read FMinWidth write FMinWidth;
    property PlainCells: Boolean read FPlainCells write FPlainCells;
    property RowMemos[Index: Integer]: TfrxCustomMemoView read GetRowMemos;
    property RowSort[Index: Integer]: TfrxCrossSortOrder read GetRowSort
      write SetRowSort;
    property RowTotalMemos[Index: Integer]: TfrxCustomMemoView read GetRowTotalMemos;
    property OnCalcHeight: TfrxCrossCalcSizeEvent read FOnCalcHeight write FOnCalcHeight;
    property OnCalcWidth: TfrxCrossCalcSizeEvent read FOnCalcWidth write FOnCalcWidth;
  end;


implementation

uses frxUtils, frxFormUtils;


function CalcSize(m: TfrxCustomMemoView): TfrxPoint;
var
  e: Extended;
begin
  m.Height := 10000;

  Result.X := m.CalcWidth;
  Result.Y := m.CalcHeight;

  if m is TfrxDMPMemoView then
  begin
    Result.X := Result.X + fr1CharX;
    Result.Y := Result.Y + fr1CharY;
  end;

  if (m.Rotation = 90) or (m.Rotation = 270) then
  begin
    e := Result.X;
    Result.X := Result.Y;
    Result.Y := e;
  end;
end;


{ TfrxIndexItem }

destructor TfrxIndexItem.Destroy;
begin
  FIndexes := nil;
  inherited;
end;


{ TfrxIndexCollection }

function TfrxIndexCollection.GetItems(Index: Integer): TfrxIndexItem;
begin
  Result := TfrxIndexItem(inherited Items[Index]);
end;

function TfrxIndexCollection.Find(const Indexes: array of Variant;
  var Index: Integer): Boolean;
var
  i, i0, i1, c: Integer;
  Item: TfrxIndexItem;

  function Compare: Integer;
  var
    i: Integer;
  begin
    Result := 0;
    for i := 0 to FIndexesCount - 1 do
      if Item.Indexes[i] = Indexes[i] then
        Result := 0
      else if Item.Indexes[i] > Indexes[i] then
      begin
        if FSortOrder[i] = soAscending then
          Result := 1 else
          Result := -1;
        break;
      end
      else if Item.Indexes[i] < Indexes[i] then
      begin
        if FSortOrder[i] = soAscending then
          Result := -1 else
          Result := 1;
        break;
      end;
  end;

begin
  Result := False;

  if FSortOrder[0] = soNone then
  begin
    for i := 0 to Count - 1 do
    begin
      Item := TfrxIndexItem(Items[i]);
      if Compare = 0 then
      begin
        Result := True;
        Index := i;
        Exit;
      end;
    end;

    Index := Count;
    Exit;
  end;

  { quick find }
  i0 := 0;
  i1 := Count - 1;

  while i0 <= i1 do
  begin
    i := (i0 + i1) div 2;
    Item := TfrxIndexItem(Items[i]);
    c := Compare;

    if c < 0 then
      i0 := i + 1
    else
    begin
      i1 := i - 1;
      if c = 0 then
      begin
        Result := True;
        i0 := i;
      end;
    end;
  end;

  Index := i0;
end;

function TfrxIndexCollection.InsertItem(Index: Integer;
  const Indexes: array of Variant): TfrxIndexItem;
var
  i: Integer;
begin
  if Index < Count then
    Result := TfrxIndexItem(Insert(Index)) else
    Result := TfrxIndexItem(Add);
  SetLength(Result.FIndexes, FIndexesCount);
  for i := 0 to FIndexesCount - 1 do
    Result.FIndexes[i] := Indexes[i];
end;


{ TfrxCrossRow }

constructor TfrxCrossRow.Create;
begin
  inherited;
  FCells := TList.Create;
end;

destructor TfrxCrossRow.Destroy;
var
  i: Integer;
  c, c1: PfrCrossCell;
begin
  for i := 0 to FCells.Count - 1 do
  begin
    c := FCells[i];
    while c <> nil do
    begin
      c1 := c;
      c := c.Next;
      VarClear(c1.Value);
      Dispose(c1);
    end;
  end;

  FCells.Free;
  inherited;
end;

procedure TfrxCrossRow.CreateCell(Index: Integer);
var
  i: Integer;
  c, c1: PfrCrossCell;
begin
  while Index >= FCells.Count do
  begin
    c1 := nil;
    for i := 0 to FCellLevels - 1 do
    begin
      New(c);
      c.Value := Null;
      c.Count := 1;
      c.Next := nil;
      if c1 <> nil then
        c1.Next := c else
        FCells.Add(c);
      c1 := c;
    end;
  end;
end;

function TfrxCrossRow.GetCellValue(Index1, Index2: Integer): Variant;
var
  c: PfrCrossCell;
begin
  Result := Null;
  if (Index1 < 0) or (Index1 >= FCells.Count) then Exit;

  c := FCells[Index1];
  while (c <> nil) and (Index2 > 0) do
  begin
    c := c.Next;
    Dec(Index2);
  end;

  if c <> nil then
    Result := c.Value;
end;

procedure TfrxCrossRow.SetCellValue(Index1, Index2: Integer; const Value: Variant);
var
  c: PfrCrossCell;
begin
  if Index1 < 0 then Exit;
  if Index1 >= FCells.Count then
    CreateCell(Index1);

  c := FCells[Index1];
  while (c <> nil) and (Index2 > 0) do
  begin
    c := c.Next;
    Dec(Index2);
  end;
  if c <> nil then
    if c.Value = Null then
      c.Value := Value else
      c.Value := c.Value + Value;
end;

function TfrxCrossRow.GetCell(Index: Integer): PfrCrossCell;
begin
  Result := nil;
  if Index < 0 then Exit;

  if Index >= FCells.Count then
    CreateCell(Index);

  Result := FCells[Index];
end;


{ TfrxCrossRows }

constructor TfrxCrossRows.Create;
begin
  inherited Create(TfrxCrossRow);
end;

function TfrxCrossRows.GetItems(Index: Integer): TfrxCrossRow;
begin
  Result := TfrxCrossRow(inherited Items[Index]);
end;

function TfrxCrossRows.InsertItem(Index: Integer;
  const Indexes: array of Variant): TfrxIndexItem;
begin
  Result := inherited InsertItem(Index, Indexes);
  TfrxCrossRow(Result).FCellLevels := FCellLevels;
end;

function TfrxCrossRows.Row(const Indexes: array of Variant): TfrxCrossRow;
var
  i: Integer;
begin
  if Find(Indexes, i) then
    Result := Items[i] else
    Result := TfrxCrossRow(InsertItem(i, Indexes));
end;


{ TfrxCrossColumns }

constructor TfrxCrossColumns.Create;
begin
  inherited Create(TfrxCrossColumn);
end;

function TfrxCrossColumns.GetItems(Index: Integer): TfrxCrossColumn;
begin
  Result := TfrxCrossColumn(inherited Items[Index]);
end;

function TfrxCrossColumns.Column(const Indexes: array of Variant): TfrxCrossColumn;
var
  i: Integer;
begin
  if Find(Indexes, i) then
    Result := Items[i] else
    Result := TfrxCrossColumn(InsertItem(i, Indexes));
end;

function TfrxCrossColumns.InsertItem(Index: Integer;
  const Indexes: array of Variant): TfrxIndexItem;
begin
  Result := inherited InsertItem(Index, Indexes);
  TfrxCrossColumn(Result).FCellIndex := Count - 1;
end;


{ TfrxCrossHeader }

constructor TfrxCrossHeader.Create(CellLevels: Integer);
begin
  FItems := TList.Create;
  FCellLevels := CellLevels;
  FValue := Null;
  FVisible := True;

  SetLength(FFuncValues, FCellLevels);
  SetLength(FCounts, FCellLevels);
end;

destructor TfrxCrossHeader.Destroy;
begin
  FFuncValues := nil;
  FCounts := nil;

  while FItems.Count > 0 do
  begin
    TfrxCrossHeader(FItems[0]).Free;
    FItems.Delete(0);
  end;

  FItems.Free;
  inherited;
end;