rm_cross.pas

进销存·完整的·有数据库的·非常完整·只得参考

begin
  Clear;
  FRows.Free;
  FColumns.Free;
  inherited Destroy;
end;

procedure TRMArray.Clear;
var
  i, j: Integer;
  sl: TList;
  p: PRMArrayCell;
begin
  for i := 0 to FRows.Count - 1 do
  begin
    sl := Pointer(FRows.Objects[i]);
    if sl <> nil then
    begin
      for j := 0 to sl.Count - 1 do
      begin
        p := sl[j];
        if p <> nil then
        begin
          VarClear(p.Items);
          Dispose(p);
        end;
      end;
    end;
    sl.Free;
  end;

  FRows.Clear;
end;

function TRMArray.GetCell(const Row, Col: string; Index3: Integer): Variant;
var
  i1, i2: Integer;
  sl: TList;
  p: PRMArrayCell;
begin
  Result := Null;
  i1 := FRows.IndexOf(Row);
  i2 := FColumns.IndexOf(Col);
  if (i1 = -1) or (i2 = -1) or (Index3 >= FCellItemsCount) then
    Exit;
  i2 := Integer(FColumns.Objects[i2]);

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

procedure TRMArray.SetCell(const Row, Col: string; Index3: Integer; Value: Variant);
var
  i, j, i1, i2: Integer;
  sl: TList;
  p: PRMArrayCell;
begin
  i1 := FRows.IndexOf(Row);
  i2 := FColumns.IndexOf(Col);
  if i2 <> -1 then
    i2 := Integer(FColumns.Objects[i2]);

  if i1 = -1 then // row does'nt exists, so create it
  begin
    sl := TList.Create;
    if FFlag_Insert and (not FRows.Sorted) and (FInsertPos < FRows.Count) then
      FRows.InsertObject(FInsertPos, Row, sl)
    else
      FRows.AddObject(Row, sl);
    i1 := FRows.IndexOf(Row);
  end;

  if i2 = -1 then // column does'nt exists, so create it
  begin
    if FFlag_Insert and (not FColumns.Sorted) then
      FColumns.InsertObject(FInsertPos, Col, TObject(FColumns.Count))
    else
      FColumns.AddObject(Col, TObject(FColumns.Count));
    i2 := FColumns.Count - 1;
  end;

  sl := Pointer(FRows.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(Row, Col, Index3: Integer): Variant;
var
  sl: TList;
  p: PRMArrayCell;
begin
  Result := Null;
  if (Row = -1) or (Col = -1) or (Index3 >= FCellItemsCount) then
    Exit;
  if Col < FColumns.Count then
    Col := Integer(FColumns.Objects[Col]);

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

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

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

procedure TRMArray.SetCellArray(Row, Col: Integer; Value: Variant);
var
  i: Integer;
  lList: TList;
  p: PRMArrayCell;
begin
  if (Row = -1) or (Col = -1) then
    Exit;
  Cell[FRows[Row], Columns[Col], 0] := 0;

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

  if Row < FRows.Count then
    lList := Pointer(FRows.Objects[Row])
  else
    lList := nil;
  if lList <> nil then
  begin
    if Col < lList.Count then
      p := lList[Col]
    else
      p := nil;
    if p <> nil then
    begin
      for i := 0 to FCellItemsCount - 1 do
        p^.Items[i] := Value[i];
    end;
  end;
end;

procedure TRMArray.SetSortColHeader(Value: Boolean);
begin
  FSortColHeader := Value;
  FColumns.Sorted := FSortColHeader;
end;

procedure TRMArray.SetSortRowHeader(Value: Boolean);
begin
  FSortRowHeader := Value;
  FRows.Sorted := FSortRowHeader;
end;

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

procedure _Sort(aStringList: TStringList);
var
  n, i: Integer;

  function _SubStrCount(aSubStr, aStr: string): Integer;
  var //取子串在子串中出现多少次
    i, l: Integer;
  begin
    Result := 0;
    l := Length(aSubStr);
    for i := 1 to Length(aStr) - l do
    begin
      if Copy(aStr, i, l) = aSubStr then
        inc(Result);
    end;
  end;

  procedure _Sort1(aStringList: TStringList; n: Integer);
  var
    i, j: Integer;
    lString1, lString2: string;
    lStrList: TStringList;

    function _PreNSubString(aString: string; n: Integer): string;
    var
      i, j, k: Integer;
    begin //取第N个';'前的子串
      j := 0;
      k := 0;
      for i := 1 to Length(aString) do
      begin
        k := i;
        if aString[i - 1] = ';' then
          inc(j);
        if j = n then
          break;
      end;
      Result := Copy(aString, 1, k - 1);
    end;

  begin
    lStrList := TStringList.Create;
    try
      for i := 0 to aStringList.Count - 1 do
      begin
        if aStringList.Strings[i] <> '' then //没有被选过的才参加选择
        begin
          lString1 := _PreNSubString(aStringList.Strings[i], n);
          lStrList.AddObject(aStringList[i], aStringList.Objects[i]);
          aStringList.Strings[i] := ''; //已经被选过的清空
          for j := (i + 1) to (aStringList.Count - 1) do //扫描剩下没有选过的串
          begin
            if aStringList.Strings[j] <> '' then
            begin
              lString2 := _PreNSubString(aStringList.Strings[j], n);
              if lString2 = lString1 then
              begin
              	lStrList.AddObject(aStringList[j], aStringList.Objects[j]);
                aStringList.Strings[j] := '';
              end;
            end;
          end;
        end;
      end;
      aStringList.Clear;
      aStringList.Assign(lStrList);
    finally
      lStrList.Free;
    end;
  end;

begin //需要进行N次排序
  n := _SubStrCount(';', aStringList.Strings[0]);
  for i := 1 to n do
  begin
    _Sort1(aStringList, i);
  end;
end;

constructor TRMCross.Create(DS: TDataSet; RowFields, ColFields, CellFields: string);
begin
  FDataSet := 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);

  FSortColHeader := True;
  FSortRowHeader := True;
  FAddColumnsHeader := TStringList.Create;
end;

destructor TRMCross.Destroy;
begin
  FRowFields.Free;
  FColFields.Free;
  FCellFields.Free;
  FAddColumnsHeader.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; aIndex: Integer);
  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);
    FFlag_Insert := (Direction and (not SortColHeader)) or(not Direction and (not SortRowHeader));
    try
      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
          begin
            FormGroup1(j);
            Inc(FInsertPos);
          end;
          Break;
        end;
      end;
    finally
			FFlag_Insert := False;
      sl1.Free; sl2.Free;
    end;
  end;

  procedure MakeTotals(sl: TStringList; Direction: Boolean); // Direction=True sl=Columns else sl=Rows
  var
    i: Integer;
    s, Old: string;
  begin
    Old := sl[0];
    i := 0;
    FInsertPos := 0;
    while i < sl.Count do
    begin
      s := sl[i];
      if (s <> Old) and (Pos('+', s) = 0) then
      begin
        FormGroup(s, Old, Direction, i - 1);
        Old := s;
      end;
      Inc(i);
    end;
    FormGroup('', sl[sl.Count - 1], Direction, sl.Count);
  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;