xlscalculate3.pas

Advanced Data Import Component Suite for Borland Delphi and C++ Builder allows you to import your da

unit XLSCalculate3;

{$I QImport3VerCtrl.Inc}

interface

uses SysUtils {$IFDEF VCL6}, Variants{$ENDIF}, XLSFile3;

function CalculateFormula(Cell: TbiffCell; ParsedData: PByteArray;
  DataSize: integer): Variant;

implementation

uses XLSCommon3, XLSConsts3, Math, XLSUtils3, Classes;

type
  TxlsStack = class(TList)
  private
    function GetItems(Index: integer): Variant;
    procedure SetItems(Index: integer; Value: Variant);
  public
    function Add(Item: Variant): integer;
    procedure Clear; {$IFDEF VCL4}override;{$ENDIF}
    procedure Delete(Index: integer);
    destructor Destroy; override;
    procedure SetLength(Length: integer);

    property Items[Index: integer]: Variant read GetItems write SetItems; default;
  end;

  TxlsCalculator = class
  private
    FStack: TxlsStack;
    FPtr: integer;
    FCell: TbiffCell;
  public
    constructor Create(Cell: TbiffCell);
    destructor Destroy; override;

    procedure Push(Value: Variant);
    function Pop: Variant;
    function  Peek: Variant;
    procedure DoOperator(Operator: byte);
    procedure DoOptimizedFunction(ID: TXLS_FUNCTION_ID);
    function DoFunction(ID: TXLS_FUNCTION_ID): boolean;
    function DoVarFunction(ID: TXLS_FUNCTION_ID; ArgCount: integer): boolean;
  end;

{ TxlsStack }

function TxlsStack.Add(Item: Variant): integer;
var
  PV: PVariant; 
begin
  New(PV);
  PV^ := Item;
  Result := inherited Add(PV);
end;

procedure TxlsStack.Clear;
var
  i: integer;
begin
  for i := Count - 1 downto 0 do
    Delete(i);
  inherited;
end;

procedure TxlsStack.Delete(Index: integer);
begin
  Dispose(PVariant(inherited Items[Index]));
  inherited;
end;

destructor TxlsStack.Destroy;
begin
  Clear;
  inherited;
end;

function TxlsStack.GetItems(Index: integer): Variant;
begin
  Result := PVariant(inherited Items[Index])^;
end;

procedure TxlsStack.SetItems(Index: integer; Value: Variant);
begin
  PVariant(inherited Items[Index])^ := Value;
end;

procedure TxlsStack.SetLength(Length: integer);
var
  i: integer;
begin
  if Length <= Count then Exit;
  for i := Count to Length - 1 do
    Add(NULL);
end;

{ TxlsCalculator }

constructor TxlsCalculator.Create(Cell: TbiffCell);
begin
  inherited Create;
  FStack := TxlsStack.Create;
  FPtr := -1;
  FCell := Cell;
end;

destructor TxlsCalculator.Destroy;
begin
  FStack.Free;
  inherited;
end;

procedure TxlsCalculator.Push(Value: Variant);
begin
  Inc(FPtr);
  if FPtr >= FStack.Count then
    FStack.SetLength(FStack.Count + 32);
  FStack[FPtr] := Value;
end;

function TxlsCalculator.Pop: Variant;
begin
  if FPtr < 0 then begin
    Result := NULL;
    Exit;
    //raise ExlsFileError.Create(sEmptyStack);
  end;
  Result := FStack[FPtr];
  Dec(FPtr);
end;

function TxlsCalculator.Peek: Variant;
begin
  Result := FStack[FPtr];
end;

procedure TxlsCalculator.DoOperator(Operator: byte);
var
  Value: variant;
begin
  if FPtr < 1 then begin
    Value := NULL;
    Exit;
    //raise ExlsFileError.Create(sValueMissing);
  end;
  case Operator of
    ptgAdd   : Value := FStack[FPtr - 1] + FStack[FPtr];
    ptgSub   : Value := FStack[FPtr - 1] - FStack[FPtr];
    ptgMul   : Value := FStack[FPtr - 1] * FStack[FPtr];
    ptgDiv   : Value := FStack[FPtr - 1] / FStack[FPtr];
    ptgPower : Value := Power(FStack[FPtr - 1], FStack[FPtr]);
    ptgConcat:
      if (VarType(FStack[FPtr - 1]) = varString) and
         (VarType(FStack[FPtr]) = varString)
        then Value := FStack[FPtr - 1] + FStack[FPtr]
        else Value := BOOL_ERR_STR_VALUE;
    ptgLT    : Value := FStack[FPtr - 1] < FStack[FPtr];
    ptgLE    : Value := FStack[FPtr - 1] <= FStack[FPtr];
    ptgEQ    : Value := FStack[FPtr - 1] = FStack[FPtr];
    ptgGE    : Value := FStack[FPtr - 1] >= FStack[FPtr];
    ptgGT    : Value := FStack[FPtr - 1] > FStack[FPtr];
    ptgNE    : Value := FStack[FPtr - 1] <> FStack[FPtr];
    ptgUPlus : Value := FStack[FPtr] + 1;
    ptgUMinus: Value := -FStack[FPtr];
  end;
  Dec(FPtr);
  FStack[FPtr] := Value
end;

procedure TxlsCalculator.DoOptimizedFunction(ID: TXLS_FUNCTION_ID);
var
  RefArea, V: Variant;
  Col, Row, Sheet: integer;
  DataCell: TbiffCell;

  function DoOperation: Variant;
  begin
    if Assigned(DataCell) then
    begin
      if DataCell.IsFloat then begin
        if VarIsNull(V) then V := DataCell.AsFloat
        else
          case ID of
            fidSum: V := V + DataCell.AsFloat;
            fidMin: if DataCell.AsFloat < V then V := DataCell.AsFloat;
            fidMax: if DataCell.AsFloat > V then V := DataCell.AsFloat;
          end;
      end
    end else
      V := 0;
  end;

begin
  if not (ID in [fidSum, fidMin, fidMax]) then Exit;

  RefArea := Pop;

  if (VarType(RefArea) and varArray) <> varArray then
    raise ExlsFileError.Create(sInvalidAreaArgument);

  V := NULL;
  case VarArrayHighBound(RefArea, 1) of
    1: begin
      Col := RefArea[0];
      Row := RefArea[1];
      DataCell := FCell.WorkSheet.Cells[Row, Col];
      DoOperation;
    end;
    2: begin
      Col := RefArea[0];
      Row := RefArea[1];
      Sheet := RefArea[2];
      DataCell := FCell.WorkSheet.Workbook.WorkSheets[Sheet].Cells[Row, Col];
      DoOperation;
    end;
    3: begin
      for Col := RefArea[0] to RefArea[2] do
        for Row := RefArea[1] to RefArea[3] do begin
          DataCell := FCell.WorkSheet.Cells[Row, Col];
          DoOperation;
        end;
    end;
    4: begin
      Sheet := RefArea[4];
      for Col := RefArea[0] to RefArea[2] do
        for Row := RefArea[1] to RefArea[3] do begin
          DataCell := FCell.WorkSheet.Workbook.WorkSheets[Sheet].Cells[Row, Col];
          DoOperation;
        end;
    end;
    else ExlsFileError.Create(sInvalidArraySize);
  end;
  Push(V);
end;

function TxlsCalculator.DoFunction(ID: TXLS_FUNCTION_ID): boolean;
begin
  Result := true;
  case ID of
    fidCos: FStack[FPtr] := Cos(FStack[FPtr]);
    fidSin: FStack[FPtr] := Sin(FStack[FPtr]);
    fidTan: FStack[FPtr] := Tan(FStack[FPtr]);
    else Result := false;
  end;
end;

function TxlsCalculator.DoVarFunction(ID: TXLS_FUNCTION_ID;
  ArgCount: integer): boolean;
var
  R: Variant;

  procedure CallOptimizedFunction;
  var
    i: integer;
  begin
    R := 0;
    for i := 0 to ArgCount - 1 do begin
      if (VarType(Peek) and varArray) = varArray then
        DoOptimizedFunction(ID);

      case ID of
        fidSum: R := R + Pop;
        fidMax,
        fidMin: R := Pop;
      end;
    end;
  end;

  procedure DoCOUNT;
  var
    i: integer;
    V: Variant;
  begin
    R := 0;
    for i := 0 to ArgCount - 1 do begin
      if (VarType(Peek) and varArray) = varArray then begin
        V := Peek;
        case VarArrayHighBound(V, 1) of
          1, 2: R := R + 1;
          3, 4: R := R + (V[2] - V[0] + 1) * (V[3] - V[1] + 1);
          else raise ExlsFileError.Create(sInvalidArraySize);
        end;
      end
      else begin
        if VarType(Peek) in [varSmallint, varInteger, varSingle, varDouble,
          varCurrency, varDate, varBoolean {$IFDEF VCL6}, varShortInt, varWord,
          varInt64, varLongWord {$ENDIF}, varByte] then
          R := R + 1;
      end;
      Pop;
    end;
  end;

  procedure DoIF;
  var
    ResTrue, ResFalse: Variant;
  begin
    if ArgCount = 3
      then ResFalse := Pop
      else ResFalse := false;

    ResTrue := Pop;
    if Pop = true
      then R := ResTrue
      else R := ResFalse;
  end;

  procedure DoIsNA;
  begin
    Push((VarType(Peek) = varString) and (Pop = BOOL_ERR_STR_NA));
  end;

  procedure DoIsERROR;
  var
    i: integer;
  begin