frxaggregate.pas

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

{******************************************}
{                                          }
{             FastReport v4.0              }
{           Aggregate Functions            }
{                                          }
{         Copyright (c) 1998-2008          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxAggregate;

interface

{$I frx.inc}

uses
  Windows, SysUtils, Classes, Dialogs, frxClass
{$IFDEF Delphi6}
, Variants
{$ENDIF};


type
  TfrxAggregateFunction = (agSum, agAvg, agMin, agMax, agCount);

  TfrxAggregateItem = class(TObject)
  private
    FAggregateFunction: TfrxAggregateFunction;
    FBand: TfrxDataBand;
    FCountInvisibleBands: Boolean;
    FDontReset: Boolean;
    FExpression: String;
    FIsPageFooter: Boolean;
    FItemsArray: Variant;      { used for vbands }
    FItemsCount: Integer;
    FItemsCountArray: Variant; { used for vbands }
    FItemsValue: Variant;
    FKeeping: Boolean;
    FLastCount: Integer;
    FLastValue: Variant;
    FMemoName: String;
    FOriginalName: String;
    FParentBand: TfrxBand;
    FReport: TfrxReport;
    FTempItemsCount: Integer;
    FTempItemsValue: Variant;
    FVColumn: Integer;         { used for vbands }
  public
    procedure Calc;
    procedure DeleteValue;
    procedure Reset;
    procedure StartKeep;
    procedure EndKeep;
    function Value: Variant;
  end;

  TfrxAggregateList = class(TObject)
  private
    FList: TList;
    FReport: TfrxReport;
    function GetItem(Index: Integer): TfrxAggregateItem;
    procedure FindAggregates(Memo: TfrxCustomMemoView; DataBand: TfrxDataBand);
    procedure ParseName(const ComplexName: String; var Func: TfrxAggregateFunction;
      var Expr: String; var Band: TfrxDataBand; var CountInvisible, DontReset: Boolean);
    property Items[Index: Integer]: TfrxAggregateItem read GetItem; default;
  public
    constructor Create(AReport: TfrxReport);
    destructor Destroy; override;
    procedure Clear;
    procedure ClearValues;

    procedure AddItems(Page: TfrxReportPage);
    procedure AddValue(Band: TfrxBand; VColumn: Integer = 0);
    procedure DeleteValue(Band: TfrxBand);
    procedure EndKeep;
    procedure Reset(ParentBand: TfrxBand);
    procedure StartKeep;
    function GetValue(ParentBand: TfrxBand; const ComplexName: String;
      VColumn: Integer = 0): Variant; overload;
    function GetValue(ParentBand: TfrxBand; VColumn: Integer;
      const Name, Expression: String; Band: TfrxBand; Flags: Integer): Variant; overload;
  end;


implementation

uses frxVariables, frxUtils;

type
  THackComponent = class(TfrxComponent);

procedure Get3Params(const s: String; var i: Integer;
  var s1, s2, s3: String);
var
  c, d, e, oi, ci: Integer;
begin
  s1 := ''; s2 := ''; s3 := '';
  c := 1; d := 1; e := 1; oi := i + 1; ci := 1;
  repeat
    Inc(i);
    if s[i] = '''' then
      if (d = 1) and (e = 1) then Inc(d) else d := 1;
    if (d = 1) and (s[i] = '"') then
      if e = 1 then Inc(e) else e := 1;
    if (d = 1) and (e = 1) then
    begin
      if s[i] = '(' then
        Inc(c) else
      if s[i] = ')' then Dec(c);
      if (s[i] = ',') and (c = 1) then
      begin
        if ci = 1 then
          s1 := Copy(s, oi, i - oi) else
          s2 := Copy(s, oi, i - oi);
        oi := i + 1; Inc(ci);
      end;
    end;
  until (c = 0) or (i >= Length(s));
  case ci of
    1: s1 := Copy(s, oi, i - oi);
    2: s2 := Copy(s, oi, i - oi);
    3: s3 := Copy(s, oi, i - oi);
  end;
  Inc(i);
end;


{ TfrxAggregateItem }

procedure TfrxAggregateItem.Calc;
var
  Value: Variant;
  i: Integer;
begin
  if not FBand.Visible and not FCountInvisibleBands then Exit;

  FReport.CurObject := FMemoName;
  if FAggregateFunction <> agCount then
    Value := FReport.Calc(FExpression) else
    Value := Null;

  if VarType(Value) = varBoolean then
    if Value = True then
      Value := 1;

  { process vbands }
  if FVColumn > 0 then
  begin
    if VarIsNull(FItemsArray) then
    begin
      FItemsArray := VarArrayCreate([0, 1000], varVariant);
      FItemsCountArray := VarArrayCreate([0, 1000], varVariant);
      for i := 0 to 1000 do
      begin
        FItemsArray[i] := Null;
        FItemsCountArray[i] := 0;
      end;
    end;

    if (FAggregateFunction <> agAvg) or (Value <> Null) then
      FItemsCountArray[FVColumn] := FItemsCountArray[FVColumn] + 1;
    if FItemsArray[FVColumn] = Null then
      FItemsArray[FVColumn] := Value
    else if Value <> Null then
      case FAggregateFunction of
        agSum, agAvg:
          FItemsArray[FVColumn] := FItemsArray[FVColumn] + Value;
        agMin:
          if Value < FItemsArray[FVColumn] then
            FItemsArray[FVColumn] := Value;
        agMax:
          if Value > FItemsArray[FVColumn] then
            FItemsArray[FVColumn] := Value;
      end;
  end
  else if FKeeping then
  begin
    if (FAggregateFunction <> agAvg) or (Value <> Null) then
      Inc(FTempItemsCount);
    if FTempItemsValue = Null then
      FTempItemsValue := Value
    else if Value <> Null then
      case FAggregateFunction of
        agSum, agAvg:
          FTempItemsValue := FTempItemsValue + Value;
        agMin:
          if Value < FTempItemsValue then
            FTempItemsValue := Value;
        agMax:
          if Value > FTempItemsValue then
            FTempItemsValue := Value;
      end;
  end
  else
  begin
    FLastCount := FItemsCount;
    FLastValue := FItemsValue;
    if (FAggregateFunction <> agAvg) or (Value <> Null) then
      Inc(FItemsCount);
    if FItemsValue = Null then
      FItemsValue := Value
    else if Value <> Null then
      case FAggregateFunction of
        agSum, agAvg:
          FItemsValue := FItemsValue + Value;
        agMin:
          if Value < FItemsValue then
            FItemsValue := Value;
        agMax:
          if Value > FItemsValue then
            FItemsValue := Value;
      end;
  end;
end;

procedure TfrxAggregateItem.DeleteValue;
begin
  FItemsCount := FLastCount;
  FItemsValue := FLastValue;
end;

procedure TfrxAggregateItem.Reset;
begin
  if FDontReset and (FItemsCount <> 0) then Exit;

  FItemsCount := 0;
  FItemsValue := Null;
  FItemsArray := Null;
  FItemsCountArray := Null;
end;

procedure TfrxAggregateItem.StartKeep;
begin
  if not FIsPageFooter or FKeeping then Exit;
  FKeeping := True;

  FTempItemsCount := 0;
  FTempItemsValue := Null;
end;

procedure TfrxAggregateItem.EndKeep;
begin
  if not FIsPageFooter or not FKeeping then Exit;
  FKeeping := False;

  FItemsCount := FItemsCount + FTempItemsCount;
  if FItemsValue = Null then
    FItemsValue  := FTempItemsValue
  else if FTempItemsValue <> Null then
    case FAggregateFunction of
      agMin:
        if FTempItemsValue < FItemsValue then
          FItemsValue := FTempItemsValue;
      agMax:
        if FTempItemsValue > FItemsValue then
          FItemsValue := FTempItemsValue;
      else
        FItemsValue := FItemsValue + FTempItemsValue;
    end;
end;

function TfrxAggregateItem.Value: Variant;
begin
  Result := Null;
  if not VarIsNull(FItemsArray) then
  begin
    case FAggregateFunction of
      agSum, agMin, agMax:
        Result := FItemsArray[FVColumn];
      agAvg:
        Result := FItemsArray[FVColumn] / FItemsCountArray[FVColumn];
      agCount:
        Result := FItemsCountArray[FVColumn];
    end
  end
  else
    case FAggregateFunction of
      agSum, agMin, agMax:
        Result := FItemsValue;
      agAvg:
        Result := FItemsValue / FItemsCount;
      agCount:
        Result := FItemsCount;
    end;

  if VarIsNull(Result) then
    Result := 0;
end;


{ TfrxAggregateList }

constructor TfrxAggregateList.Create(AReport: TfrxReport);
begin
  FList := TList.Create;
  FReport := AReport;
end;

destructor TfrxAggregateList.Destroy;
begin
  Clear;
  FList.Free;
  inherited;
end;

procedure TfrxAggregateList.Clear;
begin
  while FList.Count > 0 do
  begin
    TObject(FList[0]).Free;
    FList.Delete(0);
  end;
end;

function TfrxAggregateList.GetItem(Index: Integer): TfrxAggregateItem;
begin
  Result := FList[Index];
end;

procedure TfrxAggregateList.ParseName(const ComplexName: String;
  var Func: TfrxAggregateFunction; var Expr: String; var Band: TfrxDataBand;
  var CountInvisible, DontReset: Boolean);
var
  i: Integer;
  Name, Param1, Param2, Param3: String;
begin
  i := Pos('(', ComplexName);
  Name := UpperCase(Trim(Copy(ComplexName, 1, i - 1)));
  Get3Params(ComplexName, i, Param1, Param2, Param3);
  Param1 := Trim(Param1);
  Param2 := Trim(Param2);
  Param3 := Trim(Param3);

  if Name = 'SUM' then
    Func := agSum
  else if Name = 'MIN' then
    Func := agMin
  else if Name = 'MAX' then
    Func := agMax
  else if Name = 'AVG' then
    Func := agAvg
  else //if Name = 'COUNT' then
    Func := agCount;

  if Name <> 'COUNT' then
  begin
    Expr := Param1;
    if Param2 <> '' then
      Band := TfrxDataBand(FReport.FindObject(Param2)) else
      Band := nil;
    if Param3 <> '' then
      i := StrToInt(Param3) else
      i := 0;
  end
  else
  begin
    Expr := '';
    Band := TfrxDataBand(FReport.FindObject(Param1));