tmsuflxnumberformat.pas

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

/// Utility methods to format numbers as Excel does it.
unit tmsUFlxNumberFormat;
{$INCLUDE ..\FLXCOMPILER.INC}

interface
uses SysUtils,
  {$IFDEF FLX_NEEDSVARIANTS} variants,{$ENDIF}
     tmsUFlxMessages, Math;

  /// <summary>
  /// This method has been deprecated. Use <see cref="XlsFormatValue1904@variant@UTF16String@boolean@Integer" text="XlsFormatValue1904" />
  /// instead.
  /// </summary>
  /// <remarks>
  /// Excel has two different date systems: one starts at 1900 and the other at 1904. While 1900 is the
  /// most common (it is the default in Windows), 1904 is used in Macs and also might be set in Excel for
  /// Windows too in the options dialog.<para></para>
  /// <para></para>
  /// This method assumes always 1900 dates, so it is not safe to use and you should use &quot;1904&quot;
  /// overloads instead.
  /// </remarks>
  /// <param name="V">Value to convert.</param>
  /// <param name="Format">Format to be applied to the value. This must be an standard Excel format
  ///                      string.</param>
  /// <param name="Color">\Returns the color the text should be in, if the format contains color
  ///                     information.</param>
  /// <returns>
  /// The value formatted as a string.
  /// </returns>                                                                                                                          
  function XlsFormatValue(const V: variant; const Format: UTF16String; var Color: Integer): UTF16String;  deprecated {$IFDEF FLX_HAS_DEPRECATED_COMMENTS}'Use XlsFormatValue1904 instead.'{$ENDIF};

  /// <summary>
  /// Formats a value as Excel would show it in a cell.
  /// </summary>
  /// <remarks>
  /// If you have for example the number &quot;1&quot; stored in cell A1, and the format for the cell is
  /// &quot;0.00&quot;, Excel will displa yin the cell the string &quot;1.00&quot;, not just &quot;1&quot;.
  /// This method allows you to get what should be displayed in a cell based on the value in it and the
  /// format of the cell.
  /// </remarks>
  /// <param name="V">Value to convert.</param>
  /// <param name="Format">Format to be applied to the value. This must be an standard Excel format
  ///                      string (like &quot;0.00&quot;). </param>
  /// <param name="Color">\Returns the color the text should be in, if the format contains color
  ///                     information.</param>
  /// <param name="Dates1904">A boolean indicating if the workbook uses 1904 or 1900 dates. <b>Note that
  ///                         the result will be different depending on this parameter.</b> You will
  ///                         normally get the value for this parameter from
  ///                         TFlexCelImport.Options1904Dates</param>
  /// <returns>
  /// The value formatted as a string. 
  /// </returns>                                                                                           
  function XlsFormatValue1904(const V: variant; const Format: UTF16String; const Dates1904: boolean; var Color: Integer): UTF16String;

  /// <summary>
  /// \Returns true if the given Format string contains a Date or Time.
  /// </summary>
  /// <remarks>
  /// You can also get the data returned by this method with XlsFormatValue, but if you are only interested
  /// in knowing if a format contains a date/time, this method is easier.
  /// </remarks>
  /// <param name="Format">Format string in Excel format, like &quot;0.00&quot; or &quot;dd/mm/yyy&quot;.</param>
  /// <param name="HasDate">\Returns true if the format contains a date.</param>
  /// <param name="HasTime">Return true if the format contains time.</param>
  /// <returns>
  /// True if the format contains either a date, a time or both.
  /// </returns>                                                                                                 
  function HasXlsDateTime(const Format: UTF16String; out HasDate, HasTime: boolean): boolean;
//-----------------------------------------------------------------------------//
implementation
type
  TResultCondition = record
    SupressNeg: Boolean;
    SupressNegComp: Boolean;
    Complement: Boolean;
    Assigned: boolean;
  end;

  TResultConditionArray = Array of TResultCondition;

var
  RegionalSet : TFormatSettings; //Must be global so it is not freed when we point to it.

procedure CheckRegionalSettings(const Format: UTF16String; var RegionalCulture: PFormatSettings; var p: integer; var TextOut: UTF16String; const Quote: Boolean);
var
  StartCurr: integer;
  v: UTF16String;
  StartStr: integer;
  EndStr: integer;
  Len: integer;
  Offset: integer;
  i: integer;
  digit: AnsiChar;
  Result: integer;
  FormatLength: integer;
begin
  FormatLength := Length(Format);
  if p - 1 >= (FormatLength - 3) then
    exit;

  if copy(Format, p, 2) = '[$' then  //format is [$Currency-Locale]
  begin
    p:= p + 2;
    StartCurr := p;  //Currency
    while (Format[p] <> '-') and (Format[p] <> ']') do
    begin
      Inc(p);
      if p - 1 >= FormatLength then  //no tag found.
        exit;
    end;

    if (p - StartCurr) > 0 then
    begin
      if Quote then
        TextOut := TextOut + '"';

      v := copy(Format, StartCurr, p - StartCurr);
      if Quote then
        StringReplace(v, '"', '"\""', [rfReplaceAll]);

      TextOut := TextOut + v;
      if Quote then
        TextOut := TextOut + '"';

    end;

    if Format[p] <> '-' then
    begin
      Inc(p);
      exit;  //no culture info.
    end;

    Inc(p);
    StartStr := p;
    while (p <= FormatLength) and (Format[p] <> ']') do
    begin
      begin
        Inc(p);
      end;
    end;
    if p <= FormatLength then  //We actually found a close tag
    begin
      EndStr := p;
      Inc(p);  //add the ']' char.
      Len := Math.Min(4, EndStr - StartStr);
      Result := 0;  //to avoid issues with non existing tryparse we will convert from hexa directly.
      Offset := 0;
      for i := EndStr - 1 downto EndStr - Len do
      begin
        if (Format[i]) >=#255 then exit; //cannot parse
        digit := UpCase(AnsiChar(Format[i]));
        if (digit >= '0') and (digit <= '9') then
        begin
          Result:= Result + ((integer(digit) - integer('0')) shl Offset);
          Offset:= Offset + 4;
          continue;
        end;

        if (digit >= 'A') and (digit <= 'F') then
        begin
          Result:= Result + (((10 + integer(digit)) - integer('A')) shl Offset);
          Offset:= Offset + 4;
          continue;
        end;

        exit;  //Cannot parse.
      end;

      if Result < 0 then
        exit;

      try
        GetLocaleFormatSettings(Result, RegionalSet);
        RegionalCulture := @RegionalSet;
      except
      begin
         //We could not create the culture, so we will continue with the existing one.
       end;
      end;
    end;

  end;

end;

function GetResultCondition(const aSupressNeg: Boolean; const aSupressNegComp: Boolean; const aComplement: Boolean; const aAssigned: Boolean): TResultCondition;
begin
  Result.SupressNeg := aSupressNeg;
  Result.SupressNegComp := aSupressNegComp;
  Result.Complement := aComplement;
  Result.Assigned := aAssigned;
end;

function FindFrom(const wc: UTF16Char; const w: UTF16String; const p: integer): integer;
begin
  Result:=pos(wc, copy(w, p, Length(w)))
end;

function GetconditionNumber(const Format: UTF16String; const p: integer; out HasErrors: Boolean): Extended;
var
  p2: integer;
  number: UTF16String;
begin
  HasErrors := true;
  p2 := FindFrom(']', Format, p + 1) - 1;
  if p2 < 0 then
    begin Result := 0; exit; end;

  number := copy(Format, p + 1, p2);
  Result := 0;
  HasErrors := not TryStrToFloatInvariant(number, Result);
end;

function EvalCondition(const Format: UTF16String; const position: integer; const V: Double; out ResultValue: Boolean; out SupressNegativeSign: Boolean; out SupressNegativeSignComp: Boolean): Boolean;
var
  HasErrors: Boolean;
  c: Double;
begin
  SupressNegativeSign := false;
  SupressNegativeSignComp := false;
  ResultValue := false;
  if (position + 2) >= Length(Format) then  //We need at least a sign and a bracket.
    begin Result := false; exit; end;

  case Format[1 + position] of
  '=':
    begin
      begin
        c := GetconditionNumber(Format, position + 1, HasErrors);
        if HasErrors then
          begin Result := false; exit; end;

        ResultValue := V = c;
        SupressNegativeSign := true;
        SupressNegativeSignComp := false;
        begin Result := true; exit; end;
      end;
    end;
  '<':
    begin
      begin
        if Format[1 + position + 1] = '=' then
        begin
          c := GetconditionNumber(Format, position + 2, HasErrors);
          if HasErrors then
            begin Result := false; exit; end;

          ResultValue := V <= c;
          if c <= 0 then
            SupressNegativeSign := true else
            SupressNegativeSign := false;

          SupressNegativeSignComp := true;
          begin Result := true; exit; end;
        end;

        if Format[1 + position + 1] = '>' then
        begin
          c := GetconditionNumber(Format, position + 2, HasErrors);
          if HasErrors then
            begin Result := false; exit; end;

          ResultValue := V <> c;
          SupressNegativeSign := false;
          SupressNegativeSignComp := true;
          begin Result := true; exit; end;
        end;

        begin
          c := GetconditionNumber(Format, position + 1, HasErrors);
          if HasErrors then
            begin Result := false; exit; end;

          ResultValue := V < c;
          if c <= 0 then
            SupressNegativeSign := true else
            SupressNegativeSign := false;

          SupressNegativeSignComp := true;
          begin Result := true; exit; end;
        end;
      end;
    end;
  '>':
    begin
      begin
        if Format[1 + position + 1] = '=' then
        begin
          c := GetconditionNumber(Format, position + 2, HasErrors);
          if HasErrors then
            begin Result := false; exit; end;

          ResultValue := V >= c;
          if c <= 0 then
            SupressNegativeSignComp := true else
            SupressNegativeSignComp := false;

          SupressNegativeSign := false;
          begin Result := true; exit; end;
        end;

        begin
          c := GetconditionNumber(Format, position + 1, HasErrors);
          if HasErrors then
            begin Result := false; exit; end;

          ResultValue := V > c;
          if c <= 0 then
            SupressNegativeSignComp := true else
            SupressNegativeSignComp := false;

          SupressNegativeSign := false;
          begin Result := true; exit; end;
        end;
      end;
    end;
  end;
  Result := false;
end;

function GetNegativeSign(const Conditions: TResultConditionArray; const SectionCount: integer; var TargetedSection: integer; const V: Double): Boolean;
var
  NullCount: integer;
  CompCount: integer;
  Comp: TResultCondition;
  i: integer;
begin
  if TargetedSection < 0 then
  begin
    if (not Conditions[0].Assigned) and (((V > 0) or (SectionCount <= 1)) or ((V = 0) and (SectionCount <= 2))) then
    begin
      TargetedSection := 0;
      begin Result := false; exit; end;  //doesn't matter.
    end;

    if (not Conditions[1].Assigned) and ((V < 0) or (SectionCount <= 2)) then
    begin
      TargetedSection := 1;
      if (SectionCount = 2) and (Conditions[0].Assigned) then
        begin Result := Conditions[0].SupressNegComp; exit; end;

      begin Result := true; exit; end;
    end;

    if (not Conditions[2].Assigned) then
      TargetedSection := 2 else
      TargetedSection := 3;

    begin Result := false; exit; end;
  end;

  if Conditions[TargetedSection].Assigned then
  begin
    Result := Conditions[TargetedSection].SupressNeg; exit;
  end;

  NullCount := 0;  //Find Complement, if any
  CompCount := 0;
  Comp := GetResultCondition(false, false, false, false);
  for i := 0 to SectionCount - 1 do
  begin
    if Conditions[i].Assigned then
    begin
      Assert(Conditions[i].Complement);
      Inc(CompCount);
      if CompCount > 1 then
        begin Result := false; exit; end;

      Comp := Conditions[i];
    end
    else
    begin
      Inc(NullCount);
      if NullCount > 1 then
        begin Result := false; exit; end;

    end;

  end;

  if Comp.Assigned then
    begin Result := Comp.SupressNegComp; exit; end;

  Result := false;
end;


function GetSections(const Format: UTF16String; const V: Double; out TargetedSection: integer; out SectionCount: integer; out SupressNegativeSign: Boolean): WideStringArray;
var
  InQuote: Boolean;
  Conditions: TResultConditionArray;
  CurrentSection: integer;
  StartSection: integer;
  i: integer;
  TargetsThis: Boolean;
  SupressNegs: Boolean;
  SupressNegsComp: Boolean;
  FormatLength: Integer;
begin
  InQuote := false;
  SetLength (Result, 4);
  for i:= 0 to Length(Result) - 1 do Result[i] := '';
  SetLength (Conditions, 4);
  for i:= 0 to Length(Conditions) - 1 do Conditions[i] := GetResultCondition(false, false, false, false);
  CurrentSection := 0;
  StartSection := 0;
  TargetedSection := -1;
  i := 0;

  FormatLength := Length(Format);
  while i < FormatLength do
  begin
      if Format[1 + i] = '"' then
      begin
        InQuote := not InQuote;
      end;

      if InQuote then
      begin
        Inc(i);
        continue;  //escaped characters inside a quote like \" are not valid.
      end;

      if Format[1 + i] = '\' then
      begin
        i:= i + 2;
        continue;
      end;

      if Format[1 + i] = '[' then
      begin
        if (i + 2) < FormatLength then
        begin
          if EvalCondition(Format, i + 1, V, TargetsThis, SupressNegs, SupressNegsComp) then
          begin
            Conditions[CurrentSection] := GetResultCondition(SupressNegs, SupressNegsComp, not TargetsThis, true);
            if TargetedSection < 0 then
            begin
              if TargetsThis then
              begin
                TargetedSection := CurrentSection;