uxlsencodeformula.pas

TMS Component Pack Pro v4.2

  SkipWhiteSpace;

  GetOneReference(RowAbs1, ColAbs1, Row1, Col1);
  if (Row1>Max_Rows+1) or (Row1<=0) or (Col1<=0) or (Col1>Max_Columns+1) then
  begin
    UndoSkipWhiteSpace(SaveParsePos);
    exit;
  end;

  if PeekChar(c) and (c=fmRangeSep) then
  begin
    NextChar;
    GetOneReference(RowAbs2, ColAbs2, Row2, Col2);
    if (Row2>Max_Rows+1) or (Row2<=0) or (Col2<=0) or (Col2>Max_Columns+1) then
      raise Exception.CreateFmt(ErrUnexpectedChar, [char(c), ParsePos, Fw]);

    rw1:=Row1-1;
    grBit1:=(Col1-1) and $FF;
    if not RowAbs1 then grBit1:=grBit1 or $8000;
    if not ColAbs1 then grBit1:=grBit1 or $4000;

    rw2:=Row2-1;
    grBit2:=(Col2-1) and $FF;
    if not RowAbs2 then grBit2:=grBit2 or $8000;
    if not ColAbs2 then grBit2:=grBit2 or $4000;

    if Force3D then
    begin
      ESheet:=GetExternSheet(Default3DExternSheet);
      grBit1 := grbit1 and not $0C000;
      grBit2 := grbit2 and not $0C000;
      AddParsed([GetRealPtg(ptgArea3d,fmRef) ,lo(ESheet), hi(ESheet), lo(Rw1), hi(Rw1), lo(Rw2), hi(Rw2), lo(grBit1), hi(grBit1), lo(grBit2), hi(grBit2)]);
    end
    else
    begin
      AddParsed([GetRealPtg(ptgArea,fmRef) , lo(Rw1), hi(Rw1), lo(Rw2), hi(Rw2), lo(grBit1), hi(grBit1), lo(grBit2), hi(grBit2)]);
    end;
  end else
  begin
    rw1:=Row1-1;
    grBit1:=(Col1-1) and $FF;
    if not RowAbs1 then grBit1:=grBit1 or $8000;
    if not ColAbs1 then grBit1:=grBit1 or $4000;

    if Force3D then
    begin
      ESheet:=GetExternSheet(Default3DExternSheet);
      grBit1 := grbit1 and not $0C000;
      AddParsed([GetRealPtg(ptgRef3d,fmRef) ,lo(ESheet), hi(ESheet), lo(Rw1), hi(Rw1), lo(grBit1), hi(grBit1)]);
    end
    else
    begin
      AddParsed([GetRealPtg(ptgRef,fmRef) , lo(Rw1), hi(Rw1), lo(grBit1), hi(grBit1)]);
    end;
  end;
  Result:=true;
end;

function TParseString.IsErrorCode(const s: widestring; var b: byte): boolean;
begin
  Result:=true;
  if s= fmErrNull  then b:=fmiErrNull else
  if s= fmErrDiv0  then b:=fmiErrDiv0 else
  if s= fmErrValue then b:=fmiErrValue else
  if s= fmErrRef   then b:=fmiErrRef else
  if s= fmErrName  then b:=fmiErrName else
  if s= fmErrNum   then b:=fmiErrNum else
  if s= fmErrNA    then b:=fmiErrNA else Result:=false;
end;

procedure TParseString.GetError;
var
  b: byte;
  Start: integer;
  s: widestring;
  c: widechar;
begin
  SkipWhiteSpace;
  start:=ParsePos;

  while PeekChar(c) do
  begin
    NextChar;
    s:=WideUpperCase98(copy(FW, start, ParsePos-Start));
    if IsErrorCode(s, b) then
    begin
      AddParsed([ptgErr, b]);
      exit;
    end;

    if Length(s)>MaxErrorLen then break;
  end;

  raise Exception.CreateFmt(ErrUnexpectedId,[s,Fw]);

end;

function FindFormula(const s: widestring; var Index: integer): boolean;
var
  i:integer;
begin
  //Pending: optimize this to be binary search
  for i:=low(FuncNameArray) to High(FuncNameArray) do
    if FuncNameArray[i].Name=s then
    begin
      Result:=true;
      Index:=i;
      exit;
    end;
  Result:=False;
end;

function FuncParamType(const Index: integer; Position: integer): TFmReturnType;
begin
	if (Position+1 > Length(FuncNameArray[Index].ParamType) - 1) then Position := Length(FuncNameArray[Index].ParamType)-1;
	case (FuncNameArray[Index].ParamType[Position+1]) of
			'A': Result:= fmArray;
			'R': Result:= fmRef;
			'V': Result:= fmValue;
			'-': Result:= fmValue; //Missing Arg.
      else 	raise Exception.Create(ErrInternal);
  end; //case
end;

procedure TParseString.GetFormulaArgs(const Index: integer; var ArgCount: integer);
var
  c: Widechar;
begin
  ArgCount:=0;
  NextChar; //skip parenthesis
  while PeekChar(c) and (c<> fmCloseParen) do
  begin
    Expression;

    if PeekCharWs(c) then
      if c=fmFunctionSep then NextChar else
      if c<> fmCloseParen then raise Exception.CreateFmt(ErrUnexpectedChar, [char(c), ParsePos, Fw]);

			ConvertLastRefValueType(FuncParamType(Index, ArgCount));

    inc(argCount);
  end;

  if not PeekChar(c) then raise Exception.CreateFmt(ErrMissingParen, [Fw]);
  NextChar;

  if (ArgCount < FuncNameArray[Index].MinArgCount) or (ArgCount > FuncNameArray[Index].MaxArgCount) then
    raise Exception.CreateFmt(ErrInvalidNumberOfParams,[FuncNameArray[Index].Name, FuncNameArray[Index].MinArgCount,ArgCount]);
end;

procedure TParseString.GetFormula(const s: string);
var
  Index, ArgCount: integer;
  Ptg: byte;
begin
  if not FindFormula(s, Index) then
    raise Exception.CreateFmt(ErrFunctionNotFound,[s,Fw]);

			DirectlyInFormula := DirectlyInFormula + '1';
			try
			  GetFormulaArgs(Index, Argcount);
      finally
				Delete(DirectlyInFormula, Length(DirectlyInFormula), 1);
      end;

  if FuncNameArray[Index].MinArgCount <> FuncNameArray[Index].MaxArgCount then
  begin
    Ptg:=GetRealPtg(ptgFuncVar, FuncNameArray[Index].ReturnType);
    AddParsed([Ptg, ArgCount, lo(FuncNameArray[Index].Index), hi(FuncNameArray[Index].Index)]);
  end else
  begin
    Ptg:=GetRealPtg(ptgFunc, FuncNameArray[Index].ReturnType);
    AddParsed([Ptg, lo(FuncNameArray[Index].Index), hi(FuncNameArray[Index].Index)]);
  end;

end;

procedure TParseString.GetArray;
var
  Rows, Cols: integer;
  c: widechar;
begin
  raise exception.Create('Writing array formulas is not yet supported');
  SkipWhiteSpace;
  Rows:=1; Cols:=1;
  if not PeekChar(c) or (c<>fmOpenArray) then raise Exception.CreateFmt(ErrUnexpectedChar, [char(c), ParsePos, Fw]);
  NextChar;
  while PeekChar(c) and (c<>fmCloseArray) do
  begin
    NextChar;
    if c=fmArrayRowSep then inc(Rows) else
    if c=fmArrayColSep then inc(Cols);
  end;
  AddParsedArray([lo(Cols-1), lo(Rows-1), hi(Rows-1)]);
  //pending: add the data to array.


  if not PeekChar(c) then raise Exception.CreateFmt(ErrMissingParen, [Fw]);

  AddParsed([ptgArray, 0, 0, 0, 0, 0, 0, 0]);
end;

function TParseString.NextChar: boolean;
begin
  Result:=ParsePos<=Length(Fw);
  if Result then
  begin
    inc(ParsePos);
    if ParsePos>1024 then raise Exception.CreateFmt(ErrFormulaTooLong,[Fw]);
  end;
end;

function TParseString.PeekChar(var c: WideChar): boolean;
begin
  Result:=ParsePos<=Length(Fw);
  if Result then
  begin
    c:=Fw[ParsePos];
  end;
end;

function TParseString.Peek2Char(var c: WideChar): boolean;
begin
  Result:=ParsePos+1<=Length(Fw);
  if Result then
  begin
    c:=Fw[ParsePos+1];
  end;
end;

function TParseString.PeekCharWs(var c: WideChar): boolean;
var
  aParsePos: integer;
begin
  aParsePos:= ParsePos;
  while (aParsePos<=Length(Fw)) and (Fw[aParsePos] =' ') do begin inc(aParsePos); end;

  Result:=aParsePos<=Length(Fw);
  if Result then
  begin
    c:=Fw[aParsePos];
  end;

end;

procedure TParseString.SkipWhiteSpace;
var
  Ws: TWhitespace;
  c: widechar;
begin
  Ws.Count:=0;
  while PeekChar(c) and (c =' ') do begin NextChar; if (Ws.Count<255) then inc(Ws.Count); end;

  if ParsePos<=Length(Fw) then
  begin
    c:=Fw[ParsePos];
    if (c=fmOpenParen) then  Ws.Kind:=attr_bitFPreSpace else
    if (c=fmCloseParen) then  Ws.Kind:=attr_bitFPostSpace
    else Ws.Kind:= attr_bitFSpace;
    StackWs.Push(Ws);
  end;

end;

procedure TParseString.UndoSkipWhiteSpace(const SaveParsePos: integer);
var
  Ws: TWhiteSpace;
begin
  StackWs.Pop(Ws);
  ParsePos:=SaveParsePos;
end;

procedure TParseString.Parse;
var
  c: widechar;
  Ptr: PArrayOfByte;
begin
  LastRefOp := -1;
  DirectlyInFormula := '';
  SetLength(FParsedData,0);
  SetLength(FParsedArrayData,0);
  if not PeekChar(c) or (c<>fmStartFormula) then raise Exception.CreateFmt(ErrFormulaStart,[Fw]);
  NextChar;
  Expression;

	ConvertLastRefValueType(fmValue);

  if PeekChar(c) then raise Exception.CreateFmt(ErrUnexpectedChar,[char(c), ParsePos, Fw]);
  if StackWs.Count<>0 then raise Exception.Create(ErrInternal);

  //Try to decode what we encoded
  //something like "= >" will be encoded nicely, but will crash when decoded

  GetMem(Ptr, TotalSize);
  try
    CopyToPtr(Ptr, 0);
    try
      RPNToString(Ptr, 2, FNameTable, FCellList);
    except
      raise Exception.CreateFmt(ErrFormulaInvalid,[Fw]);
    end;
  finally
    FreeMem(Ptr);
  end; //finally
end;

procedure TParseString.PopWhiteSpace;
var
  Ws: TWhiteSpace;
begin
  StackWs.Pop(Ws);
  if Ws.Count>0 then
    AddParsed([ptgAttr,$40,Ws.Kind, Ws.Count], false);
end;


procedure TParseString.AddParsed(const s: array of byte; const PopWs: boolean=true);
begin
  if Length(s)= 0 then exit;
  if (s[0] <> ptgParen) and (s[0] <> ptgAttr) then //Those are "transparent" for reference ops.
  begin
		LastRefOp := Length(FParsedData);
	end;

  if PopWs then PopWhiteSpace;
  SetLength(FParsedData, Length(FParsedData)+ Length(s));
  move(s[0], FParsedData[Length(FParsedData)-Length(s)], Length(s));
end;

procedure TParseString.AddParsedArray(const s: array of byte);
begin
  if Length(s)= 0 then exit;
  SetLength(FParsedArrayData, Length(FParsedArrayData)+ Length(s));
  move(s[0], FParsedArrayData[Length(FParsedArrayData)-Length(s)], Length(s));
end;

function TParseString.TotalSize: integer;
begin
  Result:=2+Length(FParsedData)+Length(FParsedArrayData);
end;

procedure TParseString.CopyToPtr(const Ptr: PArrayOfByte; const aPos: integer);
var
  w: word;
begin
  w:=Length(FParsedData)+Length(FParsedArrayData);
  Move(w,ptr[aPos],2);
  Move(FParsedData[0],ptr[aPos+2], Length(FParsedData));
  Move(FParsedArrayData[0],ptr[aPos+Length(FParsedData)+2], Length(FParsedArrayData));
end;

procedure TParseString.CopyToPtrNoLen(const Ptr: PArrayOfByte; const destIndex: integer);
begin
  Move(FParsedData[0],ptr[destIndex], Length(FParsedData));
  Move(FParsedArrayData[0],ptr[destIndex+Length(FParsedData)], Length(FParsedArrayData));
end;

function TParseString.IsNumber(const c: widechar): boolean;
begin
  Result:=(ord(c)<255) and (char(c) in ['0'..'9'])
end;

function TParseString.IsAlpha(const c: widechar): boolean;
begin
  Result:=(ord(c)<255) and (char(c) in ['A'..'Z','_','\','a'..'z'])
end;

function TParseString.IsAZ(const c: widechar): boolean;
begin
  Result:=(ord(c)<255) and (char(c) in ['A'..'Z','a'..'z'])
end;

function TParseString.ATo1(const c: widechar): integer;
begin
  Result:= ord(UpCase(char(c)))-Ord('A')+1;
end;

end.