frxcross.pas

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

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

    property CellFields: TStrings read FCellFields write SetCellFields;
    property CellFunctions[Index: Integer]: TfrxCrossFunction read GetCellFunctions
      write SetCellFunctions;
    property CellMemos[Index: Integer]: TfrxCustomMemoView read GetCellMemos;
    property CellHeaderMemos[Index: Integer]: TfrxCustomMemoView read GetCellHeaderMemos;
    property ClearBeforePrint: Boolean read FClearBeforePrint write FClearBeforePrint;
    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 CornerMemos[Index: Integer]: TfrxCustomMemoView read GetCornerMemos;
    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 AddHeight: Extended read FAddHeight write FAddHeight;
    property AddWidth: Extended read FAddWidth write FAddWidth;
    property AllowDuplicates: Boolean read FAllowDuplicates write FAllowDuplicates default True;
    property AutoSize: Boolean read FAutoSize write FAutoSize default True;
    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 JoinEqualCells: Boolean read FJoinEqualCells write FJoinEqualCells default False;
    property KeepTogether: Boolean read FKeepTogether write FKeepTogether default False;
    property MaxWidth: Integer read FMaxWidth write FMaxWidth default 200;
    property MinWidth: Integer read FMinWidth write FMinWidth default 0;
    property NextCross: TfrxCustomCrossView read FNextCross write FNextCross;
    property NextCrossGap: Extended read FNextCrossGap write FNextCrossGap;
    property PlainCells: Boolean read FPlainCells write FPlainCells 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 FShowColumnTotal write FShowColumnTotal default True;
    property ShowCorner: Boolean read FShowCorner write FShowCorner default True;
    property ShowRowHeader: Boolean read FShowRowHeader write FShowRowHeader default True;
    property ShowRowTotal: Boolean read FShowRowTotal write FShowRowTotal default True;
    property ShowTitle: Boolean read FShowTitle write FShowTitle default True;
    property SuppressNullRecords: Boolean read FSuppressNullRecords write FSuppressNullRecords 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, frxVariables, frxUnicodeUtils;

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


function CalcSize(m: TfrxCustomMemoView): TfrxPoint;
var
  e, SaveHeight: Extended;
begin
  SaveHeight := m.Height;
  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;

  m.Height := SaveHeight;
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
      begin
        if (VarType(Indexes[i]) = varString) or (VarType(Indexes[i]) = varOleStr){$IFDEF Delphi12}or (VarType(Indexes[i]) = varUString){$ENDIF} then
          if VarToWideStr(Item.Indexes[i]) = VarToWideStr(Indexes[i]) then
            Result := 0
          else
          begin
            Result := -1;
            break;
          end
        else
          Result := 0;
      end
      else if VarIsNull(Indexes[i]) then
      begin
        if FSortOrder[i] = soAscending then
          Result := 1 else
          Result := -1;
        break;
      end
      else if VarIsNull(Item.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
      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;