decodeformula2.pas

一个经典的读写Excel的控件

unit DecodeFormula2;

{
********************************************************************************
******* 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 SysUtils, Classes, Contnrs, Cell2, BIFFRecsII2, ExcelFuncII2, XLSUtils2;

type TGetNameEvent = function(NameType: TFormulaNameType; SheetIndex,NameIndex,Col,Row: integer): WideString of object;

function  DecodeFmla(Version: TExcelVersion; Buf: Pointer; Len: integer; SheetIndex,ACol,ARow: integer; GetNameMethod: TGetNameEvent): WideString;
procedure ConvertShrFmla(BIFF8: boolean; Buf: Pointer; Len,ACol,ARow: integer);
procedure AdjustCell(BIFF8: boolean; Buf: Pointer; Len,DCol,DRow: integer; LockStartRow,ForceAdjust: Boolean);

type TAbsoluteRef = (arCol1,arRow1,arCol2,arRow2);
type TAbsoluteRefs = set of TAbsoluteRef;

type TFormulaRef = class(TObject)
private
     FPTG: byte;
     FRef: PByteArray;
     FAbsRef: TAbsoluteRefs;
     FCol1,FRow1: word;
     FCol2,FRow2: word;
     FSheet: integer;

     function GetIsArea: boolean;
public
     constructor Create(Pg: byte; Ref: PByteArray; Abs: TAbsoluteRefs; C1,R1,C2,R2: word; Sht: integer);

     property PTG: byte read FPTG;
     property IsArea: boolean read GetIsArea;
     property AbsRef: TAbsoluteRefs read FAbsRef;
     property Col1: word read FCol1;
     property Row1: word read FRow1;
     property Col2: word read FCol2;
     property Row2: word read FRow2;
     property Sheet: integer read FSheet;
     end;

type TFormulaRefs = class(TObjectList)
private
     FVersion: TExcelVersion;

     function GetItems(Index: integer): TFormulaRef;
     function MakeAbsR(C,R: boolean): TAbsoluteRefs; overload;
     function MakeAbsA(C1,R1,C2,R2: boolean): TAbsoluteRefs; overload;
     procedure Add(Pg: byte; Ref: PByteArray; Abs: TAbsoluteRefs; C1,R1,C2,R2: word; Sht: integer);
     procedure FindRefs(BIFF8: boolean; Buf: Pointer; Len: integer);
public
     constructor Create(Version: TExcelVersion);
     function Find(Formula: TFormulaCell): boolean;
     procedure AdjustRefR1InArea(C1,R1,C2,R2: word; Delta: integer);
     property Items[Index: integer]: TFormulaRef read GetItems; default;
     end;

var
  StrTRUE: string;
  StrFALSE: string;
  FuncArgSeparator: char;

implementation

function DecodeFmla(Version: TExcelVersion; Buf: Pointer; Len: integer; SheetIndex,ACol,ARow: integer; GetNameMethod: TGetNameEvent): WideString;
var
  i,C,R: integer;
  P,pArray: Pointer;
  B: byte;
  W: word;
  S: WideString;
  Stack: TStringList;
  InSheet: boolean;

procedure Operator(O: string);
begin
  if Stack.Count < 2 then
    Stack.Add('<Val missing>')
  else begin
    Stack[Stack.Count - 2] := Stack[Stack.Count - 2] + O + Stack[Stack.Count - 1];
    Stack.Delete(Stack.Count - 1);
  end;
  P := Pointer(Integer(P) + 1);
end;

procedure UnaryOperator(O: string);
begin
  if Stack.Count < 1 then
    Stack.Add('<Val missing>')
  else
    Stack[Stack.Count - 1] := O + Stack[Stack.Count - 1];
  P := Pointer(Integer(P) + 1);
end;

function GetArray: WideString;
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) + FuncArgSeparator;
        pArray := Pointer(Integer(pArray) + 9);
      end
      else if TArrayString(pArray^).ID = 2 then begin
        Result := Result + '"' + ByteStrToWideString(@TArrayString(pArray^).Data,TArrayString(pArray^).Len) + '"' + FuncArgSeparator;
        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
    Rout := ARow + Shortint(Rin);
  if (Rin and $4000) = 0 then
    Cout := Cin
  else
    Cout := ACol + Shortint(Cin);
end;

procedure DecodeArea8(Cin,Rin: integer; var Cout,Rout: integer);
begin
  if (Cin and $4000) = 0 then
    Cout := Shortint(Cin and $FF)
  else
    Cout := ACol + Shortint(Cin and $FF);
  if (Cin and $8000) = 0 then
    Rout := Rin
  else
    Rout := ARow + Smallint(Rin);
end;

function GetFuncArgs(Count: integer): string;
var
  i: integer;
begin
  Result := '';
  for i := Count downto 1 do begin
    Result := Result + Stack[Stack.Count - i] + FuncArgSeparator;
    Stack.Delete(Stack.Count - i);
  end;
  if Count > 0 then
    Result := Copy(Result,1,Length(Result) - 1);
end;

begin
  // The compiler warning "Return value of function 'DecodeFmla' might be undefined"
  // is impossible to get rid of. 
  Result := '';
  InSheet := False;
  Stack := TStringList.Create;
  P := Buf;
  pArray := Pointer(Integer(P) + Len);
  while (Integer(P) - Integer(Buf)) < Len do begin
    case Byte(P^) of
      0: Break;
      ptgExtend: begin
        asm inc P end;
        case Byte(P^) of
          eptgElfLel:        asm add P,4 end;
          eptgElfRw:         asm add P,4 end;
          eptgElfCol:        asm add P,4 end;
          eptgElfRwV: begin
            asm inc P end;
            Stack.Add(GetNameMethod(ntCellValue,SheetIndex,-1,PByteArray(P)[2],PWordArray(P)[0]));
            asm add P,3 end;
          end;
          eptgElfColV: begin
            asm inc P end;
            Stack.Add(GetNameMethod(ntCellValue,SheetIndex,-1,PByteArray(P)[2],PWordArray(P)[0]));
            asm add P,3 end;
          end;
          eptgElfRadical:    asm add P,13 end;
          eptgElfRadicalS:   asm add P,13 end;
          eptgElfRwS:        asm add P,4 end;
          eptgElfColS:       asm add P,4 end;
          eptgElfRwSV:       asm add P,4 end;
          eptgElfColSV:      asm add P,4 end;
          eptgElfRadicalLel: asm add P,4 end;
          eptgSxName:        asm add P,4 end;
          else
            Stack.Add(Format('Unknown eptg[%.2X]',[Byte(P^)]));
        end;
        asm inc P end;
      end;
      ptgExp:
      begin
        asm inc P end;
//        Stack.Add('<Shared>');
//        Break;
      end;
      ptgAdd: Operator('+');
      ptgSub: Operator('-');
      ptgMul: Operator('*');
      ptgDiv: Operator('/');
      ptgPower: Operator('^');
      ptgConcat: Operator('&');
      ptgLT: Operator('<');
      ptgLE: Operator('<=');
      ptgEQ: Operator('=');
      ptgGE: Operator('>=');
      ptgGT: Operator('>');
      ptgNE: Operator('<>');
      ptgUnion: Operator(',');
      ptgRange: Operator(':');
      ptgUPlus: P := Pointer(Integer(P) + 1);
      ptgUMinus: UnaryOperator('-');
      ptgPercent: UnaryOperator('%');
      ptgParen:
      begin
        Stack[Stack.Count - 1] := '(' + Stack[Stack.Count - 1] + ')';
        asm inc P end;
      end;
      ptgMissArg:
      begin
        asm inc P end;
        Stack.Add('');
      end;
      ptgStr:
      begin
        asm inc P end;
        if PByteArray(P)[1] = 0 then begin
          B := Byte(P^);
          SetLength(S,B);
          asm inc P end;
          S := ByteStrToWideString(P,B);
        end
        else begin
          B := Byte(P^) * 2;
          SetLength(S,B);
          asm inc P end;
          S := ByteStrToWideString(P,B div 2);
        end;
        P := Pointer(Integer(P) + B);
        Stack.Add('"' + S + '"');
        if Version >= xvExcel97 then
          asm inc P end;
      end;
      ptgAttr:
      begin
        asm inc P end;
        if (Byte(P^) and $04) = $04 then begin
          asm inc P end;
          P := Pointer(Integer(P) + (Word(P^) + 2) * SizeOf(word) - 3);
        end
        else if (Byte(P^) and $10) = $10 then begin
//          CheckNames(Stack.Count - 1);
          Stack[Stack.Count - 1] := 'SUM(' + Stack[Stack.Count - 1] + ')';
        end;
{
        else if (Byte(P^) and $40) = $40 then
          Stack[Stack.Count - 1] := Stack[Stack.Count - 1] + ' ';
}
        if Version < xvExcel30 then
          asm add P,2 end
        else
          asm add P,3 end;
      end;
      ptgSheet:
      begin
        InSheet := True;
        asm add P,11 end;
      end;
      ptgEndSheet:
      begin
        InSheet := False;
        asm add P,5 end;
      end;
      ptgErr:
      begin
        asm inc P end;
        Stack.Add(ErrorCodeToText(Byte(P^)));
        asm inc P end;
      end;
      ptgBool:
      begin
        asm inc P end;
        if Byte(P^) = 0 then
          Stack.Add(StrFALSE)
        else
          Stack.Add(StrTRUE);
        asm inc P end;
      end;
      ptgInt:
      begin
        asm inc P end;
        Stack.Add(IntToStr(Smallint(P^)));
        asm add P,2 end;
      end;
      ptgNum:
      begin
        asm inc P end;
        Stack.Add(FloatToStr(Double(P^)));
        asm add P,8 end;
      end;
      ptgRef,ptgRefV,ptgRefA:
      begin
        asm inc P end;
        if Version < xvExcel97 then with PPTGRef7(P)^ do begin
          Stack.Add(ColRowToRefStr(Col,Row and $3FFF,(Row and $4000) = 0,(Row and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGRef7));
        end
        else with PPTGRef8(P)^ do begin
          Stack.Add(ColRowToRefStr(Col and $3FFF,Row,(Col and $4000) = 0,(Col and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGRef8));
        end;
      end;
      ptgRefN,ptgRefNV,ptgRefNA:
      begin
        asm inc P end;
        if Version < xvExcel97 then with PPTGRef7(P)^ do begin
          DecodeArea7(Col,Row,C,R);
          Stack.Add(ColRowToRefStr(C,R,(Row and $4000) = 0,(Row and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGRef7));
        end
        else with PPTGRef8(P)^ do begin
          DecodeArea8(Col,Row,C,R);
          Stack.Add(ColRowToRefStr(C,R,(Col and $4000) = 0,(Col and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGRef8));
        end;
      end;
      ptgArea,ptgAreaV,ptgAreaA:
      begin
        asm inc P end;
        if Version < xvExcel97 then with PPTGArea7(P)^ do begin
          Stack.Add(ColRowToRefStr(Col1,Row1 and $3FFF,(Row1 and $4000) = 0,(Row1 and $8000) = 0) + ':' +
                    ColRowToRefStr(Col2,Row2 and $3FFF,(Row2 and $4000) = 0,(Row2 and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGArea7));
        end
        else with PPTGArea8(P)^ do begin
          Stack.Add(ColRowToRefStr(Col1 and $3FFF,Row1,(Col1 and $4000) = 0,(Col1 and $8000) = 0) + ':' +
                    ColRowToRefStr(Col2 and $3FFF,Row2,(Col2 and $4000) = 0,(Col2 and $8000) = 0));
          P := Pointer(Integer(P) + SizeOf(TPTGArea8));
        end;
      end;
      ptgAreaN,ptgAreaNV,ptgAreaNA:
      begin
        asm inc P end;
        if Version < xvExcel97 then with PPTGArea7(P)^ do begin
          DecodeArea7(Col1,Row1,C,R);