encodeformulaii2.pas

一个经典的读写Excel的控件

unit EncodeFormulaII2;

{
********************************************************************************
******* 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-}

interface

uses Dialogs, SysUtils, BIFFRecsII2, ExcelFuncII2, XLSUtils2, XLSRWIIResourceStrings2;

type TOperator = (opNone,opAdd,opSub,opMult,opDiv,opPower,opStrCat,opEqu,opNotEqu,
                  opLess,opGreat,opLessEqu,opGreatEqu,opLPar,opRPar,opFunc,opName,
                  opVar,opConst,opError,opStr,opRef,opArea,opRef3d,opDDE);

type TUnknownNameEvent = procedure (Name: WideString; var ID: integer) of object;
type TUnknownExternNameEvent = procedure (Path,Filename,SheetName,Ref: WideString; var ExtIndex,NameIndex: integer) of object;

type TEncodeFormula = class(TObject)
private
    FOrgFormula: WideString;
    // All operators
    FOpAll: array[0..11] of WideString;
    FFormula: WideString;
    FExcelVersion: TExcelVersion;
    FStrTRUE: WideString;
    FStrFALSE: WideString;
    FBuffer: PByteArray;
    FBufSize,FCurrBufSize: integer;
    FLastSheetIndex: integer;

    FUnknownFuncEvent: TUnknownNameEvent;
    FUnknownNameEvent: TUnknownNameEvent;
    FExternNameEvent: TUnknownExternNameEvent;
    FFormulaErrorEvent: TFormulaErrorEvent;

    function  FindOperator(S: WideString; Op: array of WideString; var FoundOp: WideString): integer;
    procedure AddPtg(Ptg: byte); overload;
    procedure AddPtg(Ptg: byte; const Data; Size: integer); overload;
    procedure AddBuf(const Data; Size: integer);
    procedure AddSpacePtg(SpaceType,Count: byte);
    function  Spaces(S: WideString): integer;
    procedure AddConstant(S: WideString);
    procedure AddVectorConst(S: WideString);
    function  AddCellRef(Exp: WideString): boolean;
    function  Add3dCellRef(Exp: WideString): boolean;
    function  AddBoolConst(Exp: WideString): boolean;
    function  AddFunction(Exp: WideString): boolean;
    function  AddVariable(Exp: WideString): boolean;
    function  AddUnary(Exp: WideString): boolean;
    procedure Scan(Exp: WideString);
    procedure UppercaseSkipQuote(var S: WideString);
    function  StrToPtg(S: WideString): byte;
    function  GetFuncId(S: WideString): integer;
    procedure Error(Id: integer; S: WideString);
public
    constructor Create;
    destructor Destroy; override;
    function  Encode(Formula: WideString; var Buf: PByteArray; BufSz: integer): integer;

    property ExcelVersion: TExcelVersion read FExcelVersion write FExcelVersion;
    property StrTRUE: WideString read FStrTRUE write FStrTRUE;
    property StrFALSE: WideString read FStrFALSE write FStrFALSE;
    property LastSheetIndex: integer read FLastSheetIndex;

    property OnUnknownFunction: TUnknownNameEvent read FUnknownFuncEvent write FUnknownFuncEvent;
    property OnUnknownName: TUnknownNameEvent read FUnknownNameEvent write FUnknownNameEvent;
    property OnExternName: TUnknownExternNameEvent read FExternNameEvent write FExternNameEvent;
    property OnFormulaError: TFormulaErrorEvent read FFormulaErrorEvent write FFormulaErrorEvent;
    end;

implementation

{$I XLSRWII2.inc}

const charQuote1 = '"';
      charQuote2 = '''';
      // Operators with most characthers must be first in the list.
      OpLevel1: array[0..0] of WideString = ('^');
      OpLevel2: array[0..1] of WideString = ('*','/');
      OpLevel3: array[0..5] of WideString = ('<>','<=','>=','=','<','>');
      OpLevel4: array[0..2] of WideString = ('+','&','-');

      SymbolFirstChar: WideString = '''_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
      ExtRefFirstChar: WideString = '''[';

      ERR_BADCONSTANT        = 1;
      ERR_INVALIDSYMBOL      = 2;
      ERR_PAR_MISS_FUNC      = 3;
      ERR_BAD_FUNCNAME       = 4;
      ERR_STR_MISSING_Q      = 5;
      ERR_STRLEN             = 6;
      ERR_UNKNOWN_NAME       = 7;
      ERR_ENCLOSING_CHAR     = 8;
      ERR_INVALID_FILENAME   = 9;
      ERR_UNARY_COUNT        = 10;

{ TEncodeFormula }


procedure TEncodeFormula.AddBuf(const Data; Size: integer);
begin
  if (FCurrBufSize + Size) > FBufSize then
    raise Exception.Create('Formula buffer overflow.');
  if Size > 0 then begin
    Move(Data,FBuffer[FCurrBufSize],Size);
    Inc(FCurrBufSize,Size);
  end;
end;

procedure TEncodeFormula.AddPtg(Ptg: byte);
begin
  if (FCurrBufSize + 1) > FBufSize then
    raise Exception.Create('Formula buffer overflow.');
  FBuffer[FCurrBufSize] := Ptg;
  Inc(FCurrBufSize);
end;

procedure TEncodeFormula.AddPtg(Ptg: byte; const Data; Size: integer);
begin
  AddPtg(Ptg);
  AddBuf(Data,Size);
end;

procedure TEncodeFormula.AddSpacePtg(SpaceType,Count: byte);
var
  D: array[0..2] of byte;
begin
  if Count > 0 then begin
    D[0] := $40;
    D[1] := SpaceType;
    D[2] := Count;
    AddPtg(ptgAttr);
    AddBuf(D,Length(D));
  end;
end;

function TEncodeFormula.Spaces(S: WideString): integer;
begin
  Result := 0;
  while (S <> '') and (S[Result + 1] = ' ') do
    Inc(Result);
end;

constructor TEncodeFormula.Create;
var
  j: integer;

procedure AddOp(Op: array of WideString);
var
  i: integer;
begin
  for i := 0 to High(Op) do
    FOpAll[j + i] := Op[i];
  Inc(j,Length(Op));
end;

begin
  j := 0;
  AddOp(OpLevel1);
  AddOp(OpLevel2);        
  AddOp(OpLevel3);
  AddOp(OpLevel4);
end;

destructor TEncodeFormula.Destroy;
begin

  inherited;
end;

function TEncodeFormula.FindOperator(S: WideString; Op: array of WideString; var FoundOp: WideString): integer;
var
  BracketCnt: integer;
  InQuote: boolean;

function OpAtPos(P: integer): boolean;
var
  i: integer;
begin
  Result := False;
  FoundOp := '';
  for i := 0 to High(Op) do begin
    case Length(Op[i]) of
      1: begin
        if S[P] = Op[i][1] then begin
          FoundOp := Op[i];
          Result := True;
          Exit;
        end;
      end;
      2: begin
        if (P > 2) and (Copy(S,P - 1,Length(Op[i])) = Op[i]) then begin
          FoundOp := Op[i];
          Result := True;
          Exit;
        end;
      end;
      else
        raise Exception.Create('[int] Invalid op length');
    end;
  end;
end;

begin
  InQuote := False;
  BracketCnt := 0;
  Result := Length(S);
  while Result > 0 do begin
    if Char(S[Result]) in [charQuote1,charQuote2] then
      InQuote := not InQuote;
    if (not InQuote) and (s[Result] = '(') then
      Inc(BracketCnt);
    if (not InQuote) and (s[Result] = ')') then
      Dec(BracketCnt);
    if (not InQuote) and (BracketCnt = 0) and OpAtPos(Result) then
      Exit;
    Dec(Result);
  end;
  Result := -1;
end;

function TEncodeFormula.Encode(Formula: WideString; var Buf: PByteArray; BufSz: integer): integer;
begin
  Result := 0;
  FLastSheetIndex := -1;
  if Trim(Formula) = '' then
    Exit;
  FBuffer := Buf;
  FBufSize := BufSz;
  FCurrBufSize := 0;
  FFormula := Formula;
  FOrgFormula := FFormula;
  UppercaseSkipQuote(FFormula);
  Scan(FFormula);
  Result := FCurrBufSize;
end;

function TEncodeFormula.AddUnary(Exp: WideString): boolean;
var
  V,P: int64;
  UnaryCount: integer;
begin
  Result := False;
  V := 0;
  P := 1;
  UnaryCount := 0;
  while (Exp <> '') and ((Exp[1] = '-') or (Exp[1] = '+')) do begin
    if Exp[1] = '-' then
      V := V or P;
    P := P shl 1;
    Exp := Copy(Exp,2,MAXINT);
    Inc(UnaryCount);
    if UnaryCount > 63 then begin
      Error(ERR_UNARY_COUNT,'');
      Exit;
    end;
  end;
  Result := UnaryCount > 0;
  if Result then begin
    P := 1 shl (UnaryCount - 1);
    Scan(Exp);
    while UnaryCount > 0 do begin
      if (V and P) = P then
        AddPtg(ptgUMinus)
      else
        AddPtg(ptgUPlus);
      P := P shr 1;
      Dec(UnaryCount);
    end;
  end;
end;

procedure TEncodeFormula.Scan(Exp: WideString);
var
  p,i: integer;
  BracketCount,Space1Count,Space2Count: integer;
  Ok: boolean;
  FoundOp: WideString;
begin
  Space1Count := Spaces(Exp);
  Space2Count := 0;

//  Exp := Trim(Exp);
  BracketCount := 0;
  if Exp = '' then
    Exit;
  if FindOperator(Exp,FOpAll,FoundOp) < 0 then begin
    while (Exp <> '') and (Exp[1] = '(') and (Exp[Length(Exp)] = ')') do begin
      Exp := Copy(Exp,2,Length(Exp) - 2);
      Inc(BracketCount);
    end;
    Space1Count := Spaces(Exp);
    Space2Count := 0;
    p := Length(Exp);
    while (p > 0) and (Exp[p] = ' ') do begin
      Inc(Space2Count);
      Dec(p);
    end;
  end;

  if Exp = '' then
    Exit;

  if BracketCount <= 0 then
    AddSpacePtg(0,Space1Count);

  if Exp[1] = charQuote2 then
    i := 2
  else
    i := 1;
  if not AddUnary(Exp) then begin
    p := FindOperator(Exp,OpLevel4,FoundOp);
    if p < 0 then
      p := FindOperator(Exp,OpLevel3,FoundOp);
    if p < 0 then
      p := FindOperator(Exp,OpLevel2,FoundOp);
    if p < 0 then
      p := FindOperator(Exp,OpLevel1,FoundOp);
    if p >= 0 then begin
      Scan(Copy(Exp,1,p - Length(FoundOp)));
      Exp := Copy(Exp,p + 1,MAXINT);
      Scan(Exp);
      AddSpacePtg(0,Spaces(Exp));
      AddPtg(StrToPtg(FoundOp));
    end
    else if WCPos(Exp[i],SymbolFirstChar + ExtRefFirstChar) > 0 then begin
      Ok := AddCellRef(Exp);
      if not Ok then
        Ok := AddBoolConst(Exp);
      if not Ok then