frxaggregate.pas

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

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

unit frxAggregate;

interface

{$I frx.inc}

uses
  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;
    FMemoName:String;
    FOriginalName:String;
    FParentBand:TfrxBand;
    FReport:TfrxReport;
    FTempItemsCount:Integer;
    FTempItemsValue:Variant;
    FVColumn:Integer; { used for vbands }
  public
    procedure Calc;
    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 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, oi, ci:Integer;
begin
  s1:= ''; s2:= ''; s3:= '';
  c:= 1; d:= 1; oi:= i+1; ci:= 1;
  repeat
    Inc(i);
    if s[i] = '''' then
      if d = 1 then Inc(d) else d:= 1;
    if d = 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]:= Null;
      end;
    end;

    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
    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
    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.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;
  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;
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