tmsuxlsencodeformula.pas

TMS Component Pack V5.0包含了超过 280 个为 Delphi 以及 C++Builder 设计的 TMS 生产控件

  end;
end;


function TParseString.GetReference(const OnlyPeek: Boolean): Boolean;
var
  SaveParsePos: Int32;
  RowAbs1: Boolean;
  ColAbs1: Boolean;
  Row1: Int32;
  Col1: Int32;
  IsFullRowRange1: Boolean;
  IsFullColRange1: Boolean;
  c: UTF16Char;
  IsArea: Boolean;
  rw1: Int32;
  grBit1: Int32;
begin
  SaveParsePos := ParsePos;
  SkipWhiteSpace;
  RowAbs1 := false;
  ColAbs1 := false;
  Row1 := 0;
  Col1 := 0;
  GetOneReference(RowAbs1, ColAbs1, Row1, Col1, IsFullRowRange1, IsFullColRange1);
  if not IsFullRowRange1 and not IsFullColRange1 then
  begin
    if (Row1>Max_Rows+1) or (Row1<=0) or (Col1<=0) or (Col1>Max_Columns+1) then
    begin
      UndoSkipWhiteSpace(SaveParsePos);
      Result := false;
      exit;
    end;
  end;

  IsArea := false;
  if PeekChar(c) and (c = fmRangeSep) then
  begin
    IsArea := GetSecondAreaPart('', OnlyPeek, Row1, Col1, RowAbs1, ColAbs1, IsFullRowRange1, IsFullColRange1);
  end;

  if not IsArea then
  begin
    if IsFullColRange1 or IsFullRowRange1 then
    begin
      UndoSkipWhiteSpace(SaveParsePos);
      begin Result := false; exit; end;
    end;

    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 not OnlyPeek then
      AddParsedRef(rw1, grBit1);
  end;

  if OnlyPeek then
  begin
    UndoSkipWhiteSpace(SaveParsePos);
  end;

  Result := true;
end;


function TParseString.IsErrorCode(const s: UTF16String; out b: byte): boolean;
begin
  Result:=true;
  b:=0;
  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: UTF16String;
  c: UTF16Char;
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: UTF16String; 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; out ArgCount: integer);
var
  c: UTF16Char;
  MoreToCome: boolean;
  ActualPos: integer;
begin
  ArgCount:=0;
  NextChar; //skip parenthesis
  c:= ' ';
  MoreToCome:=true;
  while MoreToCome do
  begin
    ActualPos := ParsePos;
    Expression;

    if (ParsePos = ActualPos) then //missing parameter.
    begin
      SkipWhiteSpace;
      if (ArgCount > 0) or (PeekChar(c) and (c=fmFunctionSep)) then
      begin
			  MakeLastWhitespaceNormal; //No real need to call this here, but this way it will behave the same as Excel. (An space before the closing parenthesis on a missing arg is not a post whitespace but a normal space)
				AddParsed([ptgMissArg]);
      end
      else
      begin
				PopWhiteSpace();
        dec(ArgCount);  //This is not a real argument, as in PI()
      end;
    end else
    begin
			ConvertLastRefValueType(FuncParamType(Index, ArgCount));
			SkipWhiteSpace();
			DiscardNormalWhiteSpace();  //No space is allowed before a ",". We only keep the whitespace if it is for closing a parenthesis.
    end;

    if PeekCharWs(c) then
    begin
			//We should not call SkipWhitespace here, as it was already called.
      if c=fmFunctionSep then
      begin
        NextChar;
				if (not PeekChar(c)) then
					raise Exception.CreateFmt(ErrUnexpectedEof, [Fw]);
      end else
      if c = fmCloseParen then
      begin
        MoreTocome:=false;
      end else raise Exception.CreateFmt(ErrUnexpectedChar, [char(c), ParsePos, Fw]);
    end else raise Exception.CreateFmt(ErrUnexpectedEof, [Fw]);


    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: UTF16String);
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, byte(FuncNameArray[Index].Index), hi(word(FuncNameArray[Index].Index))]);
  end else
  begin
    Ptg:=GetRealPtg(ptgFunc, FuncNameArray[Index].ReturnType);
    AddParsed([Ptg, byte(FuncNameArray[Index].Index), hi(word(FuncNameArray[Index].Index))]);
  end;

end;

procedure TParseString.GetArray;
var
  Rows, Cols: integer;
  c: UTF16Char;
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([byte(Cols-1), byte(Rows-1), hi(word(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(out c: UTF16Char): boolean;
begin
  Result:=ParsePos<=Length(Fw);
  if Result then
  begin
    c:=Fw[ParsePos];
  end;
end;

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

function TParseString.PeekCharWs(out c: UTF16Char): 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: UTF16Char;
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: UTF16Char;
  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(InitialRefMode);

  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, 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.DiscardNormalWhiteSpace;
var
  Ws: TWhiteSpace;
begin
	StackWs.Pop(Ws);
	if (Ws.Count>0) and (Ws.Kind <> attr_bitFSpace) then
    AddParsed([ptgAttr,$40,Ws.Kind, Ws.Count], false);
end;

procedure TParseString.MakeLastWhitespaceNormal;
var
  Ws: TWhiteSpace;
begin
  StackWs.Peek(Ws);
  Ws.Kind := attr_bitFSpace;
end;


procedure TParseString.AddParsed(const s: array of byte; const PopWs: boolean=true);
begin
  if Length(s)= 0 then exit;
  if PopWs then PopWhiteSpace;

  if (s[0] <> ptgParen) and (s[0] <> ptgAttr) then //Those are "transparent" for reference ops.
  begin
		LastRefOp := Length(FParsedData);
	end;

  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: UTF16Char): boolean;
begin
  Result:=(ord(c)<255) and (AnsiChar(c) in ['0'..'9'])
end;

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

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

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

end.