frxcrossmatrix.pas

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

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
      Item[Item.Count-1].FSize.X:= Item[Item.Count-1].FSize.X+Item.FSize.X-Width;

    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
      Item[Item.Count-1].FSize.Y:= Item[Item.Count-1].FSize.Y+Item.FSize.Y-Width;

    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
      s:= 'Grand Total';
      FRowTotalMemos[i].Style:= 'rowgrand';
    end
    else
    begin