rm_cross.pas

report machine 2.3 功能强大

  if i1 = -1 then // row does'nt exists, so create it
  begin
    sl := TList.Create;
    FArray.AddObject(Index1, sl);
    i1 := FArray.IndexOf(Index1);
  end;

  if i2 = -1 then // column does'nt exists, so create it
  begin
    FColumns.AddObject(Index2, TObject(FColumns.Count));
    i2 := FColumns.Count - 1;
  end;

  sl := Pointer(FArray.Objects[i1]);
  p := nil;
  if i2 < sl.Count then
    p := sl[i2]
  else
  begin
    i2 := i2 - sl.Count;
    for i := 0 to i2 do
    begin
      New(p);
      p^.Items := VarArrayCreate([-1, FCellItemsCount - 1], varVariant);
      for j := -1 to FCellItemsCount - 1 do
        p^.Items[j] := Null;
      sl.Add(p);
    end;
  end;
  p^.Items[Index3] := Value;
end;

function TRMArray.GetCellByIndex(Index1, Index2, Index3: Integer): Variant;
var
  sl: TList;
  p: PRMArrayCell;
begin
  Result := Null;
  if (Index1 = -1) or (Index2 = -1) or (Index3 >= FCellItemsCount) then Exit;
  if Index2 < FColumns.Count then
    Index2 := Integer(FColumns.Objects[Index2]);

  if Index1 < FArray.Count then
    sl := Pointer(FArray.Objects[Index1])
  else
    sl := nil;
  if sl <> nil then
  begin
    if Index2 < sl.Count then
      p := sl[Index2]
    else
      p := nil;
    if p <> nil then
      Result := p^.Items[Index3];
  end;
end;

function TRMArray.GetCellArray(Index1, Index2: Integer): Variant;
var
  sl: TList;
  p: PRMArrayCell;
begin
  Result := Null;
  if (Index1 = -1) or (Index2 = -1) then Exit;
  if Index2 < FColumns.Count then
    Index2 := Integer(FColumns.Objects[Index2]);

  if Index1 < FArray.Count then
    sl := Pointer(FArray.Objects[Index1])
  else
    sl := nil;
  if sl <> nil then
  begin
    if Index2 < sl.Count then
      p := sl[Index2]
    else
      p := nil;
    if p <> nil then
      Result := p^.Items;
  end;
end;

procedure TRMArray.SetCellArray(Index1, Index2: Integer; Value: Variant);
var
  i: Integer;
  sl: TList;
  p: PRMArrayCell;
begin
  if (Index1 = -1) or (Index2 = -1) then Exit;
  Cell[FArray[Index1], Columns[Index2], 0] := 0;

  if Index2 < FColumns.Count then
    Index2 := Integer(FColumns.Objects[Index2]);

  if Index1 < FArray.Count then
    sl := Pointer(FArray.Objects[Index1])
  else
    sl := nil;
  if sl <> nil then
  begin
    if Index2 < sl.Count then
      p := sl[Index2]
    else
      p := nil;
    if p <> nil then
    begin
      for i := 0 to FCellItemsCount - 1 do
        p^.Items[i] := Value[i];
    end;
  end;
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMCross}

constructor TRMCross.Create(DS: TDataSet; RowFields, ColFields, CellFields: string);
begin
  FDataSet := TDataSet(DS);
  FRowFields := TStringList.Create;
  FColFields := TStringList.Create;
  FCellFields := TStringList.Create;

  while RowFields[Length(RowFields)] in ['+', ';'] do
    RowFields := Copy(RowFields, 1, Length(RowFields) - 1);
  while ColFields[Length(ColFields)] in ['+', ';'] do
    ColFields := Copy(ColFields, 1, Length(ColFields) - 1);

  RMSetCommaText(RowFields, FRowFields);
  RMSetCommaText(ColFields, FColFields);
  RMSetCommaText(CellFields, FCellFields);

  inherited Create(FCellFields.Count);
end;

destructor TRMCross.Destroy;
begin
  FRowFields.Free;
  FColFields.Free;
  FCellFields.Free;
  inherited Destroy;
end;

procedure TRMCross.Build;
var
  i: Integer;
  f: TField;
  v: Variant;
  s1, s2: string;

  function GetFieldValues(sl: TStringList): string;
  var
    i, j, n: Integer;
    s: string;
    f: TField;
    v: Variant;
    d: Double;
  begin
    Result := '';
    for i := 0 to sl.Count - 1 do
    begin
      s := PureName(sl[i]);
      f := TField(FDataSet.FindField(CurReport.Dictionary.RealFieldName[s]));
      v := f.Value;
      if (TVarData(v).VType = varOleStr) or (TVarData(v).VType = varString) then
        Result := Result + f.AsString + ';'
      else
      begin
        if v = Null then
          d := 0
        else
        begin
          d := v;
          if sl = FRowFields then
            FRowTypes[i] := v
          else if sl = FColFields then
            FColTypes[i] := v;
        end;
        s := Format('%2.6f', [d]);
        n := 32 - Length(s);
        for j := 1 to n do
          s := ' ' + s;

        Result := Result + s + ';';
      end;
    end;
    if Result <> '' then
      Result := Copy(Result, 1, Length(Result) - 1);
  end;

  procedure FormGroup(NewGroup, OldGroup: string; Direction: Boolean);
  var
    i, j: Integer;
    sl1, sl2: TStringList;

    procedure FormGroup1(Index: Integer);
    var
      i: Integer;
      s: string;
    begin
      s := '';
      for i := 0 to Index - 1 do
        s := s + sl1[i] + ';';
      s := s + sl1[Index] + '+;+';
      if Direction then
      begin
        if HasTotal(FColFields[Index]) then
          Cell[Rows[0], s, 0] := 0
      end
      else if HasTotal(FRowFields[Index]) then
        Cell[s, Columns[0], 0] := 0;
    end;

  begin
    sl1 := TStringList.Create;
    sl2 := TStringList.Create;
    RMSetCommaText(OldGroup, sl1);
    RMSetCommaText(NewGroup, sl2);
    for i := 0 to sl1.Count - 1 do
    begin
      if (NewGroup = '') or (sl1[i] <> sl2[i]) then
      begin
        for j := sl1.Count - 1 downto i do
          FormGroup1(j);
        break;
      end;
    end;
    sl1.Free;
    sl2.Free;
  end;

  procedure MakeTotals(sl: TStringList; Direction: Boolean);
  var
    i: Integer;
    s, Old: string;
  begin
    Old := sl[0];
    i := 0;
    while i < sl.Count do
    begin
      s := sl[i];
      if (s <> Old) and (Pos('+', s) = 0) then
      begin
        FormGroup(s, Old, Direction);
        Old := s;
      end;
      Inc(i);
    end;
    FormGroup('', sl[sl.Count - 1], Direction);
  end;

  procedure CalcTotals(FieldsSl, RowsSl, ColumnsSl: TStringList);
  var
    i, j, k, i1: Integer;
    l: TList;
    cg: TRMCrossGroupItem;
  begin
    l := TList.Create;
    l.Add(TRMCrossGroupItem.Create(Self, '', FieldsSl.Count, FCellItemsCount)); // grand total
    for i := 0 to FieldsSl.Count - 1 do
      l.Add(TRMCrossGroupItem.Create(Self, ColumnsSl[0], i, FCellItemsCount));

    for i := 0 to RowsSl.Count - 1 do
    begin
      for k := 0 to FieldsSl.Count do
        TRMCrossGroupItem(l[k]).Reset(ColumnsSl[0], 0);
      for j := 0 to ColumnsSl.Count - 1 do
      begin
        for k := 0 to FieldsSl.Count do
        begin
          cg := TRMCrossGroupItem(l[k]);
          if cg.IsBreak(ColumnsSl[j]) or
            ((k = 0) and (j = ColumnsSl.Count - 1)) then
          begin
            if (k = 0) or HasTotal(FieldsSl[k - 1]) then
            begin
              cg.CheckAvg;
              if RowsSl = Rows then
              begin
                CellArray[i, j] := cg.Value;
                Cell[Rows[0], Columns[j], -1] := cg.FStartFrom;
              end
              else
              begin
                CellArray[j, i] := cg.Value;
                Cell[Rows[j], Columns[0], -1] := cg.FStartFrom;
              end;
            end;

            i1 := j;
            while i1 < ColumnsSl.Count do
            begin
              if Pos('+;+', ColumnsSl[i1]) = 0 then
                break;
              Inc(i1);
            end;
            if i1 < ColumnsSl.Count then
              cg.Reset(ColumnsSl[i1], j);
            break;
          end
          else if Pos('+;+', ColumnsSl[j]) = 0 then
          begin
            if RowsSl = Rows then
              cg.AddValue(CellArray[i, j])
            else
              cg.AddValue(CellArray[j, i]);
          end;
        end;
      end;
    end;

    for i := 0 to FieldsSl.Count do
      TRMCrossGroupItem(l[i]).Free;
    l.Free;
  end;

  procedure CheckAvg;
  var
    i, j: Integer;
    v, n: Variant;
    Check: Boolean;

    procedure CalcAvg(i1, j1: Integer);
    var
      i, j, k: Integer;
      v1: Variant;
    begin
      for i := 0 to FCellFields.Count - 1 do
      begin
        v[i] := 0;
        n[i] := 0;
      end;

      for i := CellByIndex[i1, 0, -1] to i1 - 1 do
      begin
        for j := CellByIndex[0, j1, -1] to j1 - 1 do
        begin
          if (not IsTotalRow[i]) and (not IsTotalColumn[j]) then
          begin
            for k := 0 to FCellFields.Count - 1 do
            begin
              if FuncName(FCellFields[k]) = 'avg' then
              begin
                v1 := CellByIndex[i, j, k];
                if v1 <> Null then
                begin
                  n[k] := n[k] + 1;
                  v[k] := v[k] + v1;
                end;
              end;
            end;
          end;
        end;
      end;

      for i := 0 to FCellFields.Count - 1 do
      begin
        if FuncName(FCellFields[i]) = 'avg' then
        begin
          if n[i] <> 0 then
            Cell[Rows[i1], Columns[j1], i] := v[i] / n[i]
          else
            Cell[Rows[i1], Columns[j1], i] := Null;
        end;
      end;
    end;

  begin
    v := VarArrayCreate([0, FCellFields.Count - 1], varVariant);
    n := VarArrayCreate([0, FCellFields.Count - 1], varInteger);

    Check := False;
    for i := 0 to FCellFields.Count - 1 do
    begin
      if FuncName(FCellFields[i]) = 'avg' then
      begin
        Check := True;
        break;
      end;
    end;

    if Check then
    begin
      for i := 0 to Rows.Count - 1 do
      begin
        if IsTotalRow[i] or (i = Rows.Count - 1) then
        begin
          for j := 0 to Columns.Count - 1 do
          begin
            if IsTotalColumn[j] or (j = Columns.Count - 1) then
              CalcAvg(i, j);
          end;
        end;
      end;
    end;

    for i := 0 to Rows.Count - 1 do
      Cell[Rows[i], Columns[0], -1] := Null;
    for i := 0 to Columns.Count - 1 do
      Cell[Rows[0], Columns[i], -1] := Null;

    VarClear(v);
    VarClear(n);
  end;

  procedure MakeColumnHeader;
  var
    i, j, n, cn: Integer;
    s: string;
    sl, sl1: TStringList;
    Flag: Boolean;
    d: Double;
    v: Variant;

    function CompareSl(Index: Integer): Boolean;
    begin
      Result := (sl.Count > Index) and (sl1.Count > Index) and (sl[Index] = sl1[Index]);
    end;

  begin
    sl := TStringList.Create;
    sl1 := TStringList.Create;
    cn := CharCount(';', Columns[0]) + 1; // height of header
    FTopLeftSize.cy := cn;

    for i := 0 to cn do
      Cell[Chr(i), Columns[0], 0] := '';

    for i := 0 to Columns.Count - 1 do
      Cell[#0, Columns[i], -1] := RMftTop + RMftBottom;

    Cell[#0, Columns[0], 0] := FHeaderString;
    Cell[#0, Columns[0], -1] := RMftLeft + RMftTop + RMftBottom;
    Cell[#0, Columns[Columns.Count - 1], -1] := RMftTop + RMftRight;

    for i := 1 to cn do
      Cell[Chr(i), Columns[Columns.Count - 1], -1] := RMftLeft + RMftRight;

    Cell[#1, Columns[Columns.Count - 1], 0] := FColumnGrandTotalString;
    Cell[#1, Columns[Columns.Count - 1], -1] := RMftLeft + RMftTop + RMftRight;

    for i := 0 to Columns.Count - 2 do
    begin
      s := Columns[i];
      RMSetCommaText(s, sl);
      if Pos('+;+', s) <> 0 then
      begin
        n := CharCount(';', s);

        for j := 1 to n - 1 do
          Cell[Chr(j), s, -1] := RMftTop;

        for j := n to cn do
        begin
          if j = n then
          begin
            Cell[Chr(j), s, 0] := FColumnTotalString;
            Cell[Chr(j), s, -1] := RMftRight + RMftLeft + RMftTop;
          end
          else
            Cell[Chr(j), s, -1] := RMftRight + RMftLeft;
        end;
      end
      else
      begin
        Flag := False;
        for j := 0 to cn - 1 do
        begin
          if (not Flag) and CompareSl(j) then
            Cell[Chr(j + 1), s, -1] := RMftTop
          else
          begin
            if TVarData(FColTypes[j]).VType = varDate then
            begin
              d := StrToFloat(Trim(sl[j]));
              TVarData(FColTypes[j]).VDate := d;
              v := FColTypes[j];
            end
            else if (TVarData(FColTypes[j]).VType = varString) or
              (TVarData(FColTypes[j]).VType = varOleStr) or