frxcross.pas

这个是功能强大的报表软件

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

unit frxCross;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, Controls, Graphics, Forms,
  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;

  { 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;
  TfrxSortArray = array [0..31] 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: TList;
    FTotalMemos: TList;
    FCounts: TfrxVariantArray;
    FCellIndex: Integer;            { help to determine cell index for cell header }
    FCellLevels: Integer;
    FFuncValues: TfrxVariantArray;
    FHasCellHeaders: Boolean;       { top level item only }
    FIndex: Integer;                { index of the item }
    FIsCellHeader: Boolean;
    FIsIndex: Boolean;              { used in IndexItems to determine if item is index }
    FIsTotal: Boolean;              { is this cell a total cell }
    FItems: TList;                  { subcells }
    FLevelsCount: Integer;          { number of header levels }
    FMemo: TfrxCustomMemoView;      { memo for this cell }
    FNoLevels: Boolean;             { true if no items in row/column header }
    FParent: TfrxCrossHeader;       { parent of the cell }
    FSize: TfrxPoint;
    FTotalIndex: Integer;           { will help to choose which header memo to use }
    FValue: Variant;                { value (text) of the cell }
    FVisible: Boolean;              { visibility of the cell }

    function AddCellHeader(Memos: TList; Index, CellIndex: Integer): TfrxCrossHeader;
    function AddChild(Memo: TfrxCustomMemoView): TfrxCrossHeader;
    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);

    function GetCount: Integer;
    function GetItems(Index: Integer): TfrxCrossHeader;
    function GetLevel: Integer;
    function GetHeight: Extended;
    function GetWidth: Extended;
  public
    constructor Create(CellLevels: Integer);
    destructor Destroy; override;
    procedure CalcBounds; virtual; abstract;
    procedure CalcSizes(MaxWidth, MinWidth: Integer; AutoSize: Boolean); virtual; abstract;

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

    property Bounds: TfrxRect read FBounds write FBounds;
    property Count: Integer read GetCount;
    property HasCellHeaders: Boolean read FHasCellHeaders write FHasCellHeaders;
    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
    FCorner: TfrxCrossHeader;
  public
    procedure CalcBounds; override;
    procedure CalcSizes(MaxWidth, MinWidth: Integer; AutoSize: Boolean); override;
  end;

  { the cross rows }
  TfrxCrossRowHeader = class(TfrxCrossHeader)
  private
    FCorner: TfrxCrossHeader;
  public
    procedure CalcBounds; override;
    procedure CalcSizes(MaxWidth, MinWidth: Integer; AutoSize: Boolean); override;
  end;

  { the cross corner }
  TfrxCrossCorner = class(TfrxCrossColumnHeader)
  end;


  { cutted bands }
  TfrxCutBandItem = class(TCollectionItem)
  public
    Band: TfrxBand;
    FromIndex: Integer;
    ToIndex: Integer;
    destructor Destroy; override;
  end;

  TfrxCutBands = class(TCollection)
  private
    function GetItems(Index: Integer): TfrxCutBandItem;
  public
    constructor Create;
    procedure Add(ABand: TfrxBand; AFromIndex, AToIndex: Integer);
    property Items[Index: Integer]: TfrxCutBandItem read GetItems; default;
  end;

  { design-time grid resize support }
  TfrxGridLineItem = class(TCollectionItem)
  public
    Coord: Extended;
    Objects: TList;
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  end;

  TfrxGridLines = class(TCollection)
  private
    function GetItems(Index: Integer): TfrxGridLineItem;
  public
    constructor Create;
    procedure Add(AObj: TObject; ACoord: Extended);
    property Items[Index: Integer]: TfrxGridLineItem read GetItems; default;
  end;

  
  { custom cross object }
{$IFDEF FR_COM}
  TfrxCustomCrossView = class(TfrxView, IfrxCustomCrossView)
{$ELSE}
  TfrxCustomCrossView = class(TfrxView)
{$ENDIF}
  private
    FAddHeight: Extended;
    FAddWidth: Extended;
    FAllowDuplicates: Boolean;
    FAutoSize: Boolean;
    FBorder: Boolean;
    FCellFields: TStrings;
    FCellFunctions: array[0..31] of TfrxCrossFunction;
    FCellLevels: Integer;
    FClearBeforePrint: Boolean;
    FColumnBands: TfrxCutBands;
    FColumnFields: TStrings;
    FColumnHeader: TfrxCrossColumnHeader;
    FColumnLevels: Integer;
    FColumns: TfrxCrossColumns;
    FColumnSort: TfrxSortArray;
    FCorner: TfrxCrossCorner;
    FDefHeight: Integer;
    FDotMatrix: Boolean;
    FDownThenAcross: Boolean;
    FFirstMousePos: TPoint;
    FGapX: Integer;
    FGapY: Integer;
    FGridUsed: TfrxGridLines;
    FGridX: TfrxGridLines;
    FGridY: TfrxGridLines;
    FJoinEqualCells: Boolean;
    FKeepTogether: Boolean;
    FLastMousePos: TPoint;
    FMaxWidth: Integer;
    FMinWidth: Integer;
    FMouseDown: Boolean;
    FMovingObjects: Integer;
    FNextCross: TfrxCustomCrossView;
    FNextCrossGap: Extended;
    FNoColumns: Boolean;
    FNoRows: Boolean;
    FPlainCells: Boolean;
    FRepeatHeaders: Boolean;
    FRowBands: TfrxCutBands;
    FRowFields: TStrings;
    FRowHeader: TfrxCrossRowHeader;
    FRowLevels: Integer;
    FRows: TfrxCrossRows;
    FRowSort: TfrxSortArray;
    FShowColumnHeader: Boolean;
    FShowColumnTotal: Boolean;
    FShowCorner: Boolean;
    FShowRowHeader: Boolean;
    FShowRowTotal: Boolean;
    FShowTitle: Boolean;
    FSuppressNullRecords: Boolean;

    FAllMemos: TList;
    FCellMemos: TList;
    FCellHeaderMemos: TList;
    FColumnMemos: TList;
    FColumnTotalMemos: TList;
    FCornerMemos: TList;
    FRowMemos: TList;
    FRowTotalMemos: TList;

    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 }

    procedure CalcBounds(addWidth, addHeight: Extended);
    procedure CalcTotal(Header: TfrxCrossHeader; Source: TfrxIndexCollection);
    procedure CalcTotals;
    procedure CreateHeader(Header: TfrxCrossHeader; Source: TfrxIndexCollection;
      Totals: TList; TotalVisible: Boolean);
    procedure CreateHeaders;

    procedure AddSourceObjects;
    procedure BuildColumnBands;
    procedure BuildRowBands;
    procedure ClearMatrix;
    procedure ClearMemos;
    procedure CreateCellHeaderMemos(NewCount: Integer);
    procedure CreateCellMemos(NewCount: Integer);
    procedure CreateColumnMemos(NewCount: Integer);
    procedure CreateCornerMemos(NewCount: Integer);
    procedure CreateRowMemos(NewCount: Integer);
    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 InitMatrix;
    procedure InitMemos(AddToScript: Boolean);
    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 SetDotMatrix(const Value: Boolean);
    procedure SetRowFields(const Value: TStrings);
    procedure SetRowSort(Index: Integer; Value: TfrxCrossSortOrder);
    procedure SetupOriginalComponent(Obj1, Obj2: TfrxComponent);
    procedure UpdateVisibility;
    procedure WriteMemos(Stream: TStream);
    function CreateMemo(Parent: TfrxComponent): TfrxCustomMemoView;
    function GetCellFunctions(Index: Integer): TfrxCrossFunction;
    function GetCellHeaderMemos(Index: Integer): TfrxCustomMemoView;
    function GetCellMemos(Index: Integer): TfrxCustomMemoView;
    function GetColumnMemos(Index: Integer): TfrxCustomMemoView;
    function GetColumnSort(Index: Integer): TfrxCrossSortOrder;
    function GetColumnTotalMemos(Index: Integer): TfrxCustomMemoView;
    function GetCornerMemos(Index: Integer): TfrxCustomMemoView;
    function GetNestedObjects: TList;
    function GetRowMemos(Index: Integer): TfrxCustomMemoView;
    function GetRowSort(Index: Integer): TfrxCrossSortOrder;
    function GetRowTotalMemos(Index: Integer): TfrxCustomMemoView;
  protected
    procedure DefineProperties(Filer: TFiler); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure SetCellLevels(const Value: Integer); virtual;
    procedure SetColumnLevels(const Value: Integer); virtual;
    procedure SetRowLevels(const Value: Integer); virtual;
    function GetContainerObjects: TList; override;
{$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 BeforeStartReport; override;
    procedure GetData; override;
    function ContainerAdd(Obj: TfrxComponent): Boolean; override;
    function ContainerMouseDown(Sender: TObject; X, Y: Integer): Boolean; override;
    procedure ContainerMouseMove(Sender: TObject; X, Y: Integer); override;
    procedure ContainerMouseUp(Sender: TObject; X, Y: Integer); override;

    procedure AddValue(const Rows, Columns, Cells: array of Variant);
    procedure ApplyStyle(Style: TfrxStyles);
    procedure BeginMatrix;
    procedure EndMatrix;
    procedure FillMatrix; virtual;
    procedure GetStyle(Style: TfrxStyles);

    function ColCount: Integer;
    function DrawCross(Canvas: TCanvas; ScaleX, ScaleY, OffsetX, OffsetY: Extended): TfrxPoint;
    function GetColumnIndexes(AColumn: Integer): Variant;
    function GetRowIndexes(ARow: Integer): Variant;
    function GetValue(ARow, AColumn, ACell: Integer): Variant;
    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 RowCount: Integer;
    function RowHeaderWidth: Extended;
    function ColumnHeaderHeight: Extended;