frxcrossmatrix.pas

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

function TfrxCrossHeader.GetItems(Index: Integer): TfrxCrossHeader;
begin
  Result := TfrxCrossHeader(FItems[Index]);
end;

function TfrxCrossHeader.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TfrxCrossHeader.GetLevel: Integer;
var
  h: TfrxCrossHeader;
begin
  Result := -2;
  h := Self;

  while h <> nil do
  begin
    h := h.Parent;
    Inc(Result);
  end;
end;

function TfrxCrossHeader.Find(Value: Variant): Integer;
var
  i: Integer;
begin
  { find the cell containing the given value }
  Result := -1;
  for i := 0 to Count - 1 do
//    if AnsiCompareText(VarToStr(Items[i].Value), VarToStr(Value)) = 0 then
    if VarToStr(Items[i].Value) = VarToStr(Value) then
    begin
      Result := i;
      Exit;
    end;
end;

procedure TfrxCrossHeader.AddValues(const Values: array of Variant);
var
  i, j: Integer;
  Header, Header1: TfrxCrossHeader;
  v: Variant;
  s: String;
begin
  { create the header tree. For example, subsequent calls
      AddValues([1998,1]);
      AddValues([1998,2]);
      AddValues([1999,1]);
    will create the header
      1998 | 1999
      --+--+-----
      1 |2 | 1                }


  Header := Self;

  for i := Low(Values) to High(Values) do
  begin
    j := Header.Find(Values[i]);
    if j <> -1 then
      Header := Header.Items[j]   { find existing item... }
    else
    begin
      { ...or create new one }
      Header1 := TfrxCrossHeader(NewInstance);
      Header1.Create(FCellLevels);
      { link it to the parent }
      Header.FItems.Add(Header1);
      Header1.FParent := Header;

      v := Values[i];
      s := VarToStr(v);
      { this is subtotal item }
      if Pos('@@@', s) = 1 then
      begin
        { remove @@@ }
        s := Copy(s, 4, Length(s) - 5);
        v := s;
        Header1.FIsTotal := True;
        Header1.FMemo := FTotalMemos[i];
      end
      else
        Header1.FMemo := FMemos[i];

      Header1.FValue := v;
      Header := Header1;

      if Header.FIsTotal then break;
    end;
  end;
end;

procedure TfrxCrossHeader.Reset(const CellFunctions: array of TfrxCrossFunction);
var
  i: Integer;
  h: TfrxCrossHeader;
begin
  { reset aggregate values for this cell and all its parent cells }
  h := Self;

  while h <> nil do
  begin
    for i := 0 to FCellLevels - 1 do
    begin
      case CellFunctions[i] of
        cfNone, cfMin, cfMax:
          h.FFuncValues[i] := Null;

        cfSum, cfAvg, cfCount:
          h.FFuncValues[i] := 0;
      end;

      h.FCounts[i] := 0;
    end;

    h := h.Parent;
  end;
end;

procedure TfrxCrossHeader.AddFuncValues(const Values, Counts: array of Variant;
  const CellFunctions: array of TfrxCrossFunction);
var
  i: Integer;
  h: TfrxCrossHeader;
begin
  { add aggregate values for this cell and all its parent cells }
  h := Self;

  while h <> nil do
  begin
    for i := 0 to FCellLevels - 1 do
      if Values[i] <> Null then
        case CellFunctions[i] of
          cfNone:;

          cfSum:
            h.FFuncValues[i] := h.FFuncValues[i] + Values[i];

          cfMin:
            if (h.FFuncValues[i] = Null) or (Values[i] < h.FFuncValues[i]) then
              h.FFuncValues[i] := Values[i];

          cfMax:
            if (h.FFuncValues[i] = Null) or (Values[i] > h.FFuncValues[i]) then
              h.FFuncValues[i] := Values[i];

          cfAvg:
            begin
              h.FFuncValues[i] := h.FFuncValues[i] + Values[i];
              h.FCounts[i] := h.FCounts[i] + Counts[i];
            end;

          cfCount:
            h.FFuncValues[i] := h.FFuncValues[i] + Values[i];// + Counts[i];
        end;

    h := h.Parent;
  end;
end;

function TfrxCrossHeader.AllItems: TList;

  procedure EnumItems(Item: TfrxCrossHeader);
  var
    i: Integer;
  begin
    if Item.Parent <> nil then
      Result.Add(Item);

    for i := 0 to Item.Count - 1 do
      EnumItems(Item[i]);
  end;

begin
  { list all items in the header }
  Result := TList.Create;
  EnumItems(Self);
end;

function TfrxCrossHeader.TerminalItems: TList;
var
  i: Integer;
begin
  { list all terminal items in the header }
  Result := AllItems;
  i := 0;
  while i < Result.Count do
    if TfrxCrossHeader(Result[i]).Count <> 0 then
      Result.Delete(i) else
      Inc(i);
end;

function TfrxCrossHeader.GetIndexes: Variant;
var
  ar: array[0..CROSS_DIM_SIZE - 1] of Variant;
  i, n: Integer;
  h, h1: TfrxCrossHeader;
begin
  n := 0;
  h := Parent;
  h1 := Self;
  while h <> nil do
  begin
    ar[n] := h.FItems.IndexOf(h1);
    Inc(n);
    h1 := h;
    h := h.Parent;
  end;

  Result := VarArrayCreate([0, CROSS_DIM_SIZE - 1], varVariant);
  for i := 0 to CROSS_DIM_SIZE - 1 do
    if i < n then
      Result[i] := ar[n - i - 1] else
      Result[i] := Null;
end;

function TfrxCrossHeader.GetValues: Variant;
var
  ar: array[0..CROSS_DIM_SIZE - 1] of Variant;
  i, n: Integer;
  h: TfrxCrossHeader;
begin
  n := 0;
  h := Self;
  while h.Parent <> nil do
  begin
    ar[n] := h.Value;
    Inc(n);
    h := h.Parent;
  end;

  Result := VarArrayCreate([0, CROSS_DIM_SIZE - 1], varVariant);
  for i := 0 to CROSS_DIM_SIZE - 1 do
    if i < n then
      Result[i] := ar[n - i - 1] else
      Result[i] := Null;
end;

procedure TfrxCrossHeader.CalcSizes(MaxWidth, MinWidth: Integer);
var
  i: Integer;
  Items: TList;
  Item: TfrxCrossHeader;
  s: String;
begin
  Items := AllItems;

  for i := 0 to Items.Count - 1 do
  begin
    Item := Items[i];
    Item.FMemo.Width := MaxWidth;
    s := Item.FMemo.Text;
    Item.FMemo.Text := Item.FMemo.FormatData(Item.Value);
    Item.FSize := CalcSize(Item.FMemo);
    Item.FMemo.Text := s;

    if Item.FSize.X < MinWidth then
      Item.FSize.X := MinWidth;
    if Item.FSize.X > MaxWidth then
      Item.FSize.X := MaxWidth;
  end;

  Items.Free;
end;

function TfrxCrossHeader.GetHeight: Extended;
var
  Items: TList;
begin
  Items := TerminalItems;

  if (Items.Count > 0) and FVisible then
    Result := TfrxCrossHeader(Items[Items.Count - 1]).Bounds.Top +
      TfrxCrossHeader(Items[Items.Count - 1]).Bounds.Bottom else
    Result := 0;

  Items.Free;
end;

function TfrxCrossHeader.GetWidth: Extended;
var
  Items: TList;
begin
  Items := TerminalItems;

  if (Items.Count > 0) and FVisible then
    Result := TfrxCrossHeader(Items[Items.Count - 1]).Bounds.Left +
      TfrxCrossHeader(Items[Items.Count - 1]).Bounds.Right else
    Result := 0;

  Items.Free;
end;

function TfrxCrossHeader.GetCellSizes(Index: Integer): Extended;
begin
  Result := FCellSizes[Index];
end;

procedure TfrxCrossHeader.SetCellSizes(Index: Integer;
  const Value: Extended);
begin
  FCellSizes[Index] := Value;
end;


{ TfrxCrossColumnHeader }

procedure TfrxCrossColumnHeader.CalcBounds;
var
  i, j, l: Integer;
  h: Extended;
  Items: TList;
  Item: TfrxCrossHeader;
  LevelHeights: array of Extended;

  function DoAdjust(Item: TfrxCrossHeader): Extended;
  var
    i: Integer;
    Width: Extended;
  begin
    if Item.Count = 0 then
    begin
      Result := Item.FSize.X;
      Exit;
    end;

    Width := 0;
    for i := 0 to Item.Count - 1 do
      Width := Width + DoAdjust(Item[i]);

    if Item.FSize.X < Width then
      Item.FSize.X := Width
    else
    begin
      Item[Item.Count - 1].FSize.X := Item[Item.Count - 1].FSize.X + Item.FSize.X - Width;
      DoAdjust(Item[Item.Count - 1]);
    end;

    Result := Item.FSize.X;
  end;

  procedure FillBounds(Item: TfrxCrossHeader; Offset: TfrxPoint);
  var
    i, j, l: Integer;
    h: Extended;
  begin
    l := Item.Level;
    if l <> -1 then
      h := LevelHeights[l] else
      h := 0;

    if Item.IsTotal then
      for j := l + 1 to FLevelsCount - 1 do
        h := h + LevelHeights[j];

    Item.FBounds := frxRect(Offset.X, Offset.Y, Item.FSize.X, h);
    Offset.Y := Offset.Y + h;

    for i := 0 to Item.Count - 1 do
    begin
      FillBounds(Item[i], Offset);
      Offset.X := Offset.X + Item[i].FSize.X;
    end;
  end;

begin
  DoAdjust(Self);

  SetLength(LevelHeights, FLevelsCount);

  Items := AllItems;

// calculate height of each row
  for i := 0 to Items.Count - 1 do
  begin
    Item := Items[i];
    l := Item.Level;

    if Item.IsTotal then
      if l <> FLevelsCount - 1 then continue;

    if l >= 0 then
      if Item.FSize.Y > LevelHeights[l] then
        LevelHeights[l] := Item.FSize.Y;
  end;

// adjust totals
  for i := 0 to Items.Count - 1 do
  begin
    Item := Items[i];
    l := Item.Level;

    if Item.IsTotal and (l < FLevelsCount - 1) then
    begin
      h := 0;
      for j := l to FLevelsCount - 1 do
        h := h + LevelHeights[j];

      if Item.FSize.Y > h then
        LevelHeights[FLevelsCount - 1] := LevelHeights[FLevelsCount - 1] + Item.FSize.Y - h;
    end;
  end;

  FillBounds(Self, frxPoint(0, 0));

  Items.Free;
  LevelHeights := nil;
end;


{ TfrxCrossRowHeader }

procedure TfrxCrossRowHeader.CalcBounds;
var
  i, j, l: Integer;
  h: Extended;
  Items: TList;
  Item: TfrxCrossHeader;
  LevelHeights: array of Extended;

  function DoAdjust(Item: TfrxCrossHeader): Extended;
  var
    i: Integer;
    Width: Extended;
  begin
    if Item.Count = 0 then
    begin
      Result := Item.FSize.Y;
      Exit;
    end;

    Width := 0;
    for i := 0 to Item.Count - 1 do
      Width := Width + DoAdjust(Item[i]);

    if Item.FSize.Y < Width then
      Item.FSize.Y := Width
    else
    begin
      Item[Item.Count - 1].FSize.Y := Item[Item.Count - 1].FSize.Y + Item.FSize.Y - Width;
      DoAdjust(Item[Item.Count - 1]);
    end;

    Result := Item.FSize.Y;
  end;

  procedure FillBounds(Item: TfrxCrossHeader; Offset: TfrxPoint);
  var
    i, j, l: Integer;
    h: Extended;
  begin
    l := Item.Level;
    if l <> -1 then
      h := LevelHeights[l] else
      h := 0;

    if Item.IsTotal then
      for j := l + 1 to FLevelsCount - 1 do
        h := h + LevelHeights[j];

    Item.FBounds := frxRect(Offset.X, Offset.Y, h, Item.FSize.Y);
    Offset.X := Offset.X + h;

    for i := 0 to Item.Count - 1 do
    begin
      FillBounds(Item[i], Offset);
      Offset.Y := Offset.Y + Item[i].FSize.Y;
    end;
  end;

begin
  DoAdjust(Self);

  SetLength(LevelHeights, FLevelsCount);

  Items := AllItems;

// calculate height of each row
  for i := 0 to Items.Count - 1 do
  begin
    Item := Items[i];
    l := Item.Level;

    if Item.IsTotal then
      if l <> FLevelsCount - 1 then continue;

    if l >= 0 then
      if Item.FSize.X > LevelHeights[l] then
        LevelHeights[l] := Item.FSize.X;
  end;

// adjust totals
  for i := 0 to Items.Count - 1 do
  begin
    Item := Items[i];
    l := Item.Level;

    if Item.IsTotal and (l < FLevelsCount - 1) then
    begin
      h := 0;
      for j := l to FLevelsCount - 1 do
        h := h + LevelHeights[j];

      if Item.FSize.X > h then
        LevelHeights[FLevelsCount - 1] := LevelHeights[FLevelsCount - 1] + Item.FSize.X - h;
    end;
  end;

  FillBounds(Self, frxPoint(0, 0));

  Items.Free;
  LevelHeights := nil;
end;


{ TfrxCrossMatrix }

constructor TfrxCrossMatrix.Create;
begin
  FGapX := 3;
  FGapY := 3;
  InitMemos(False);
end;

destructor TfrxCrossMatrix.Destroy;
begin
  Clear;
  ClearMemos;
  inherited;
end;

procedure TfrxCrossMatrix.InitMemos(DotMatrix: Boolean);
var
  i: Integer;
  s: String;

  procedure SetDefProps(m: TfrxCustomMemoView);
  begin
    m.HAlign := haCenter;
    m.VAlign := vaCenter;
    m.Frame.Typ := [ftLeft, ftRight, ftTop, ftBottom];
  end;

  function CreateMemo: TfrxCustomMemoView;
  begin
    if DotMatrix then
      Result := TfrxDMPMemoView.Create(nil) else
      Result := TfrxMemoView.Create(nil);
  end;

begin
  ClearMemos;
  for i := 0 to CROSS_DIM_SIZE - 1 do
  begin
    FCellMemos[i] := CreateMemo;
    FColumnMemos[i] := CreateMemo;
    FColumnTotalMemos[i] := CreateMemo;
    FRowMemos[i] := CreateMemo;
    FRowTotalMemos[i] := CreateMemo;
    FCellFunctions[i] := cfSum;
    FColumnSort[i] := soAscending;
    FRowSort[i] := soAscending;

    SetDefProps(FCellMemos[i]);
    FCellMemos[i].HAlign := haRight;
    FCellMemos[i].Style := 'cell';
    FCellMemos[i].Tag := i;

    SetDefProps(FColumnMemos[i]);
    FColumnMemos[i].Style := 'column';
    FColumnMemos[i].Tag := 100 + i;

    SetDefProps(FColumnTotalMemos[i]);
    if i = 0 then
    begin
      s := 'Grand Total';
      FColumnTotalMemos[i].Style := 'colgrand';
    end
    else
    begin
      s := 'Total';
      FColumnTotalMemos[i].Style := 'coltotal';
    end;
    FColumnTotalMemos[i].Text := s;
    FColumnTotalMemos[i].Font.Style := [fsBold];
    FColumnTotalMemos[i].Tag := 300 + i;

    SetDefProps(FRowMemos[i]);
    FRowMemos[i].Style := 'row';
    FRowMemos[i].Tag := 200 + i;

    SetDefProps(FRowTotalMemos[i]);
    if i = 0 then
    begin