calculateformula2.pas

一个经典的读写Excel的控件

unit CalculateFormula2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}
{$I XLSRWII2.inc}

interface

uses SysUtils, Classes, Math, BIFFRecsII2, ExcelFuncII2, XLSUtils2, XLSReadWriteII2,
     XLSRWIIResourceStrings2, Cell2;

function CalculateFmla(XLS: TXLSReadWriteII2; Buf: Pointer; Len: integer; ACol,ARow,ASheetIndex: integer; Options: TCalculateOptions): TFormulaValue;

implementation

type TVarStack = class(TObject)
private
    FStack: array of TFormulaValue;
    FStackPtr: integer;
    FXLS: TXLSReadWriteII2;
    FSheetIndex: integer;
    procedure IncStack;
    procedure Push(Value: TFormulaValue); overload;
    procedure Push(Value: WideString); overload;
    procedure Push(Value: double); overload;
    procedure Push(Value: boolean); overload;
    procedure PushRef(Col,Row: word);
    procedure PushArea(Col1,Row1,Col2,Row2: word);
//    procedure PushXRef(Col,Row,Sheet: word);
    procedure PushXArea(Col1,Row1,Col2,Row2,Sheet: word);
    function  Pop: TFormulaValue;
    function  Peek: TFormulaValue;
    procedure Operator(Op: Byte);
    function  Func(Id: TFunctionId): boolean;
    function  FuncVar(Id: TFunctionId; ArgCount: integer): boolean;
    procedure SumRef;
public
    constructor Create(XLS: TXLSReadWriteII2; SheetIndex: integer);
    destructor Destroy; override;
    end;

procedure CheckArgCount(Id: Integer; Count: integer);
begin
  if (Count < ExcelFunctions[Id].Min) or (Count > ExcelFunctions[Id].Max) then
    raise Exception.CreateFmt('Wrong number of arguments (%d) to function %s',[Count,ExcelFunctions[Id].Name]);
end;

procedure ValueIsVector(Id: Integer; Value: TFormulaValue);
var
  Ok: boolean;
begin
  Ok := False;
  if Value.ValType in TFormulaValTypeRef then begin
    if Value.ValType in [fvArea,fvExtArea] then
      Ok := (Value.vArea[0] = Value.vArea[2]) or (Value.vArea[1] = Value.vArea[3])
    else
      Ok := True;
  end;
  if not Ok then
    raise Exception.CreateFmt('Wrong type of argument to function %s',[ExcelFunctions[Id].Name]);
end;

function DoLOOKUP(XLS: TXLSReadWriteII2; Args: array of TFormulaValue): TFormulaValue;
var
  Cmp: double;
  Col,Row,pCol,pRow: integer;

procedure SetResult;
begin
  if Length(Args) = 3 then
    Result := XLS.Sheets[0].AsFormulaValue[Args[2].vArea[0] + (pCol - Args[1].vArea[0]),Args[2].vArea[1] + (pRow - Args[1].vArea[1])]
  else
    Result := XLS.Sheets[0].AsFormulaValue[pCol,pRow];
end;

begin
  FVSetError(Result,errNA);
  CheckArgCount(28,Length(Args));
  ValueIsVector(28,Args[1]);
  if Length(Args) = 3 then
    ValueIsVector(28,Args[2]);
  pCol := -1;
  pRow := -1;
  for Row := Args[1].vArea[1] to Args[1].vArea[3] do begin
    for Col := Args[1].vArea[0] to Args[1].vArea[2] do begin
      if not FVCompare(XLS.Sheets[0].AsFormulaValue[Col,Row],Args[0],Cmp) then
        Exit;
      if Cmp >= 0 then begin
        if pCol < 0 then
          Exit;
        if Cmp = 0 then begin
          pCol := Col;
          pRow := Row;
        end;
        SetResult;
        Exit;
      end;
      pCol := Col;
      pRow := Row;
    end;
  end;
  if (Cmp < 0) and (pCol >= 0) then
    SetResult;
end;

function DoVLOOKUP(XLS: TXLSReadWriteII2; Args: array of TFormulaValue): TFormulaValue;
begin
  CheckArgCount(102,Length(Args));
end;

function DoROUND(XLS: TXLSReadWriteII2; Args: array of TFormulaValue): TFormulaValue;
begin
  CheckArgCount(Integer(fiRound),2);
  if (Args[0].ValType <> fvFloat) or (Args[1].ValType <> fvFloat) then
    raise Exception.Create('Argument must be numeric');
{$ifdef OLD_COMPILER }
  FVSetFloat(Result,Round(Args[0].vFloat));
{$else}
  FVSetFloat(Result,RoundTo(Args[0].vFloat,Round(Args[1].vFloat)));
{$endif}
end;

{ TVarStack }

procedure TVarStack.SumRef;
var
  Col,Row,Index: integer;
  varRef: TFormulaValue;
  V: TFormulaValue;
begin
  varRef := Pop;
  if not (varRef.ValType in [fvRef,fvArea]) then
    raise Exception.Create(ersInvalidRef);
  V.vFloat := 0;
  case varRef.ValType of
    fvRef: begin
      Col := varRef.vRef[0];
      Row := varRef.vRef[1];
      V.vFloat := FXLS.Sheets[FSheetIndex].AsFloat[Col,Row];
    end;
    fvArea: begin
      for Col := varRef.vArea[0] to varRef.vArea[2] do begin
        for Row := varRef.vArea[1] to varRef.vArea[3] do
          V.vFloat := V.vFloat + FXLS.Sheets[FSheetIndex].AsFloat[Col,Row];
      end;
    end;
    fvExtRef: begin
      Col := varRef.vExtRef[0];
      Row := varRef.vExtRef[1];
      Index := varRef.vExtRef[2];
      V.vFloat := FXLS.Sheets[Index].AsFloat[Col,Row];
    end;
    fvExtArea: begin
      Index := varRef.vExtArea[4];
      for Col := varRef.vExtArea[0] to varRef.vExtArea[2] do begin
        for Row := varRef.vExtArea[1] to varRef.vExtArea[3] do
          V.vFloat := V.vFloat + FXLS.Sheets[Index].AsFloat[Col,Row];
      end;
    end;
  end;
  Push(V);
end;

constructor TVarStack.Create(XLS: TXLSReadWriteII2; SheetIndex: integer);
begin
  FXLS := XLS;
  FSheetIndex := SheetIndex;
  SetLength(FStack,32);
  FStackPtr := -1;
end;

destructor TVarStack.Destroy;
begin
  SetLength(FStack,0);
  inherited;
end;

function TVarStack.Func(Id: TFunctionId): boolean;
begin
  Result := True;
  case Id of
    fiCos: FStack[FStackPtr].vFloat := Cos(FStack[FStackPtr].vFloat);
    fiSin: FStack[FStackPtr].vFloat := Sin(FStack[FStackPtr].vFloat);
    fiTan: FStack[FStackPtr].vFloat := Tan(FStack[FStackPtr].vFloat);
    else
      Result := False;
  end;
end;

function TVarStack.FuncVar(Id: TFunctionId; ArgCount: integer): boolean;
var
  Res: TFormulaValue;

procedure DoSUM;
var
  i: integer;
begin
  Res.vFloat := 0;
  Res.ValType := fvFloat;
  for i := 0 to ArgCount - 1 do begin
    if Peek.ValType in TFormulaValTypeRef then begin
      SumRef;
      Res.vFloat := Res.vFloat + Pop.vFloat;
    end
    else
      Res.vFloat := Res.vFloat + Pop.vFloat;
  end;
end;

procedure DoCOUNT;
var
  i: integer;
  V: TFormulaValue;
begin
  Res.vFloat := 0;
  for i := 0 to ArgCount - 1 do begin
    if Peek.ValType in TFormulaValTypeRef then begin
      V := Peek;
      case V.ValType of
        fvRef,fvExtRef:
          Res.vFloat := Res.vFloat + 1;
        fvArea,fvExtArea:
          Res.vFloat := Res.vFloat + (V.vArea[2] - V.vArea[0] + 1) * (V.vArea[3] - V.vArea[1] + 1);
        else
          raise Exception.Create(ersInvalidVariantArraySize);
      end;
    end
    else begin
      if Peek.ValType = fvFloat then
        Res.vFloat := Res.vFloat + 1;
    end;
    Pop;
  end;
end;

procedure DoIF;
var
  ResTrue,ResFalse: TFormulaValue;
begin
  if ArgCount = 3 then
    ResFalse := Pop
  else
    ResFalse.vBoolean := False;
  ResTrue := Pop;
  if Pop.vBoolean = True then
    Res := ResTrue
  else
    Res := ResFalse;
end;

{
procedure DoIsNA;
begin
  Push((VarType(Peek) = varOleStr) and (Pop = CellErrorNames[ERR_NA]));
end;

procedure DoIsERROR;
var
  i: integer;
begin
  for i := 1 to High(CellErrorNames) do begin
    if (VarType(Peek) = varOleStr) and (Peek = CellErrorNames[i]) then begin
      Pop;
      Push(True);
      Exit;
    end;
  end;
  Push(False);
end;

procedure DoAVERAGE;
var
  i,Cnt: integer;
  V: Variant;
begin
  Res := 0;
  Cnt := 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:
          Inc(Cnt);
        3,4:
          Cnt := Cnt + (V[2] - V[0] + 1) * (V[3] - V[1] + 1);
        else
          raise Exception.Create(ersInvalidVariantArraySize);
      end;
      SumRef;
      Res := Res + Peek;
    end
    else begin
      if VarType(Peek) in [varSmallint,varInteger,varSingle,varDouble,varCurrency,varDate,varBoolean,
      varByte] then begin
        Inc(Cnt);
        Res := Res + Peek;
      end;
    end;
    Pop;
  end;
  Res := Res / Cnt;
end;
}

begin
  Result := True;
  case Id of
    fiCount:   DoCOUNT;
    fiIf:      DoIF;

//    fiIsNa:    DoIsNA;
//    fiIsError: DoIsERROR;
    fiSum:     DoSUM;
//    fiAverage: DoAVERAGE;
//    fiRound:   DoROUND;
    else
      Result := False;
  end;
  if Result then
    Push(Res);
end;

procedure TVarStack.Operator(Op: Byte);
var
  V: TFormulaValue;
begin
  if FStackPtr < 1 then
    raise Exception.Create(ersValueIsMissing);
  case Op of
    ptgAdd:    V.vFloat := FStack[FStackPtr - 1].vFloat + FStack[FStackPtr].vFloat;
    ptgSub:    V.vFloat := FStack[FStackPtr - 1].vFloat - FStack[FStackPtr].vFloat;
    ptgMul:    V.vFloat := FStack[FStackPtr - 1].vFloat * FStack[FStackPtr].vFloat;
    ptgDiv:    V.vFloat := FStack[FStackPtr - 1].vFloat / FStack[FStackPtr].vFloat;
    ptgPower:  V.vFloat := Power(FStack[FStackPtr - 1].vFloat,FStack[FStackPtr].vFloat);
{
    ptgConcat: begin
      if (FStack[FStackPtr - 1].ValType = fvString) and (FStack[FStackPtr].ValType = fvString) then
        V := FStack[FStackPtr - 1] + FStack[FStackPtr]
      else
        V := CellErrorNames[3];
    end;
}    
    ptgLT: V.vBoolean := FStack[FStackPtr - 1].vFloat <  FStack[FStackPtr].vFloat;
    ptgLE: V.vBoolean := FStack[FStackPtr - 1].vFloat <= FStack[FStackPtr].vFloat;
    ptgEQ: V.vBoolean := FStack[FStackPtr - 1].vFloat =  FStack[FStackPtr].vFloat;
    ptgGE: V.vBoolean := FStack[FStackPtr - 1].vFloat >= FStack[FStackPtr].vFloat;
    ptgGT: V.vBoolean := FStack[FStackPtr - 1].vFloat >  FStack[FStackPtr].vFloat;
    ptgNE: V.vBoolean := FStack[FStackPtr - 1].vFloat <> FStack[FStackPtr].vFloat;
    ptgUPlus: V.vFloat := FStack[FStackPtr].vFloat + 1;
    ptgUMinus: V.vFloat := -FStack[FStackPtr].vFloat
{
    ptgPercent: UnaryOperator('%');
}
  end;
  Dec(FStackPtr);
  FStack[FStackPtr] := V;
end;

function TVarStack.Peek: TFormulaValue;
begin
  Result := FStack[FStackPtr];
end;

function TVarStack.Pop: TFormulaValue;
begin
  if FStackPtr < 0 then
    raise Exception.Create(ersEmptyStack);
  Result := FStack[FStackPtr];
  Dec(FStackPtr);
end;

procedure TVarStack.IncStack;
begin
  Inc(FStackPtr);
  if FStackPtr >= High(FStack) then
    SetLength(FStack,Length(FStack) + 32);
end;

procedure TVarStack.Push(Value: TFormulaValue);
begin
  IncStack;
  FStack[FStackPtr] := Value;
end;

function CalculateFmla(XLS: TXLSReadWriteII2; Buf: Pointer; Len: integer; ACol,ARow,ASheetIndex: integer; Options: TCalculateOptions): TFormulaValue;
var
  i,j,C,R: integer;
  varRef: TFormulaValue;
  V: double;
  P,pArray: Pointer;
  B,O: byte;
  S: WideString;
  VStack: TVarStack;
  InSheet: boolean;

function GetArray: string;
var
  i,j: integer;
begin
  Result := '';
  C := PPTGArray(pArray).Cols;
  R := PPTGArray(pArray).Rows;
  pArray := Pointer(Integer(pArray) + 3);
  for i := 0 to C do begin
    Result := Result + '{';
    for j := 0 to R do begin
      if TArrayFloat(pArray^).ID = 1 then begin
        Result := Result + FloatToStr(TArrayFloat(pArray^).Value) + ';';
        pArray := Pointer(Integer(pArray) + 9);
      end
      else if TArrayString(pArray^).ID = 2 then begin
        Result := Result + '"' + ByteStrToWideString(@TArrayString(pArray^).Data,TArrayString(pArray^).Len) + '"' + ';';
        pArray := Pointer(Integer(pArray) + TArrayString(pArray^).Len + 4);
      end
      else
        Result := 'Bad element ID#' + IntToStr(TArrayFloat(pArray^).ID) + ' in array';
    end;
  end;
end;

procedure DecodeArea7(Cin: byte; Rin: word; var Cout,Rout: integer);
begin
  if (Rin and $8000) = 0 then
    Rout := Smallint(Rin and $FF)
  else