frxcross.pas

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

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 VarToWideStr(Items[i].Value) = VarToWideStr(Value) then
    begin
      Result := i;
      Exit;
    end;
end;

function TfrxCrossHeader.AddChild(Memo: TfrxCustomMemoView): TfrxCrossHeader;
begin
  Result := TfrxCrossHeader(NewInstance);
  Result.Create(FCellLevels);
  { link it to the parent }
  FItems.Add(Result);
  Result.FParent := Self;

  Result.FLevelsCount := FLevelsCount;
  Result.FMemo := Memo;
  Result.FValue := Memo.Text;
end;

function TfrxCrossHeader.AddCellHeader(Memos: TList; Index, CellIndex: Integer): TfrxCrossHeader;
begin
  Result := TfrxCrossHeader(NewInstance);
  Result.Create(FCellLevels);
  { link it to the parent }
  FItems.Add(Result);
  Result.FParent := Self;

  Result.FIndex := Index;
  Result.FCellIndex := CellIndex;
  Result.FLevelsCount := FLevelsCount;
  Result.FIsTotal := FIsTotal;
  Result.FTotalIndex := FTotalIndex;
  Result.FMemo := Memos[FTotalIndex * FCellLevels + CellIndex];
  Result.FValue := Result.FMemo.Text;
  Result.FIsCellHeader := True;
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);
      Header1.FLevelsCount := FLevelsCount;
      { 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];
        Header1.FTotalIndex := FLevelsCount - 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.Memo <> 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;
  Item: TfrxCrossHeader;
begin
  { list all terminal items in the header }
  Result := AllItems;
  i := 0;
  while i < Result.Count do
  begin
    Item := Result[i];
    if Item.Count = 0 then
      Inc(i)
    else
      Result.Delete(i);
  end;
end;

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

function TfrxCrossHeader.GetIndexes: Variant;
var
  ar: array of Variant;
  i, n: Integer;
  h, h1: TfrxCrossHeader;
begin
  SetLength(ar, FLevelsCount + 1);
  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, FLevelsCount - 1], varVariant);
  for i := 0 to FLevelsCount - 1 do
    if i < n then
      Result[i] := ar[n - i - 1] else
      Result[i] := Null;
  ar := nil;
end;

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

  Result := VarArrayCreate([0, FLevelsCount - 1], varVariant);
  for i := 0 to FLevelsCount - 1 do
    if i < n then
      Result[i] := ar[n - i - 1] else
      Result[i] := Null;
  ar := nil;
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;


{ 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 := Item.FSize.Y;

    if Item.FIsCellHeader then
      h := LevelHeights[FLevelsCount]
    else 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 + 1);

  Items := AllItems;

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

    // cell headers always adjust the last level height
    if Item.FIsCellHeader then
      l := FLevelsCount
    // don't count total elemens unless they are on last level.
    // such elements will be adjusted later
    else 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;

  if FNoLevels then
    LevelHeights[0] := 0;

// adjust level height - count totals that not on the last level
  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;

  { syncronize height of CornerMemos[0] and [1] }
  if FCorner <> nil then
  begin
    if not FMemo.Visible then
      FSize.Y := 0;
    if not FCorner.FMemo.Visible then
      FCorner.FSize.Y := 0;
    h := FSize.Y;
    if FCorner.FSize.Y > h then
      h := FCorner.FSize.Y;
    FSize.Y := h;
    if not FNoLevels then
      FCorner.FSize.Y := h;
  end;

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

  { update height of CornerMemos[2..n] }
  if FCorner <> nil then
  begin
    h := 0;
    l := FLevelsCount - 1;
    if HasCellHeaders then
      Inc(l);
    for i := 0 to l do
      h := h + LevelHeights[i];
    if FNoLevels then