frxcrossmatrix.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

{******************************************}
{ }
{ FastReport v3.0 }
{ Cross classes }
{ }
{ Copyright (c) 1998-2005 }
{ 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;

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;