tmsuflxnumberformat.pas

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

              end;

            end;

          end;

        end;

         //Quotes inside brackets are not quotes. So we need to process the full bracket.
        while (i < FormatLength) and (Format[1 + i] <> ']') do
        begin
          Inc(i)
        end;
        Inc(i);
        continue;
      end;

      if Format[1 + i] = ';' then
      begin
        if i > StartSection then
          Result[CurrentSection] := copy(Format, StartSection + 1, i - StartSection);

        Inc(CurrentSection);
        SectionCount := CurrentSection;
        if CurrentSection >= Length(Result) then
        begin
          SupressNegativeSign := GetNegativeSign(Conditions, SectionCount, TargetedSection, V);
          exit;
        end;

        StartSection := i + 1;
      end;

      Inc(i);
  end;

  if i > StartSection then
    Result[CurrentSection] := copy(Format, StartSection + 1, i - StartSection + 1);

  Inc(CurrentSection);
  SectionCount := CurrentSection;
  SupressNegativeSign := GetNegativeSign(Conditions, SectionCount, TargetedSection, V);
end;

function GetSection(const Format: UTF16String; const V: Double; out SectionMatches: Boolean; out SupressNegativeSign: Boolean): UTF16String;
var
  TargetedSection: integer;
  SectionCount: integer;
  Sections: WideStringArray;
begin
  SectionMatches := true;
  Sections := GetSections(Format, V, TargetedSection, SectionCount, SupressNegativeSign);
  if TargetedSection >= SectionCount then
  begin
    SectionMatches := false;  //No section matches condition. This has changed in Excel 2007, older versions would show an empty cell here, and Excel 2007 displays "####". We will use Excel2007 formatting.
    begin Result := ''; exit; end;
  end;

  if Sections[TargetedSection] = null then
    Result := '' else
    Result := Sections[TargetedSection];

end;


//we include this so we don't need to use graphics
const
  clBlack = $000000;
  clGreen = $008000;
  clRed = $0000FF;
  clYellow = $00FFFF;
  clBlue = $FF0000;
  clFuchsia = $FF00FF;
  clAqua = $FFFF00;
  clWhite = $FFFFFF;


procedure CheckColor(const Format: UTF16String; var Color: integer; out p: integer);
var
  s: string;
  IgnoreIt: boolean;
begin
  p:=1;
  if (Length(Format)>0) and (Format[1]='[') and (pos(']', Format)>0) then
  begin
    IgnoreIt:=false;
    s:=copy(Format,2,pos(']', Format)-2);
    if s = 'Black'  then Color:=clBlack else
    if s = 'Cyan'   then Color:=clAqua else
    if s = 'Blue'   then Color:=clBlue else
    if s = 'Green'  then Color:=clGreen else
    if s = 'Magenta'then Color:=clFuchsia else
    if s = 'Red'    then Color:=clRed else
    if s = 'White'  then Color:=clWhite else
    if s = 'Yellow' then Color:=clYellow

    else IgnoreIt:=true;

    if not IgnoreIt then p:= Pos(']', Format)+1;
  end;
end;

procedure CheckOptional(const V: Variant; const Format: UTF16String; var p: integer; var TextOut: UTF16String);
var
  p2, p3: integer;
begin
  if p>Length(Format) then exit;
  if Format[p]='[' then
  begin
    p2:=FindFrom(']', Format, p);
    if (p<Length(Format))and(Format[p+1]='$') then //currency
    begin
      p3:=FindFrom('-', Format+'-', p);
      TextOut:=TextOut + copy(Format, p+2, min(p2,p3)-3);
    end;
    Inc(p, p2);
  end;
end;

procedure CheckLiteral(const V: Variant; const Format: UTF16String; var p: integer; var TextOut: UTF16String);
var
  FormatLength: integer;
begin
  FormatLength := Length(Format);
  if p>FormatLength then exit;
  if (ord(Format[p])<255) and (AnsiChar(Format[p]) in[' ','$','(',')','!','^','&','''',#$B4,'~','{','}','=','<','>']) then
    begin
      TextOut:=TextOut+Format[p];
      inc(p);
      exit;
    end;

  if (Format[p]='\') or (Format[p]='*')then
    begin
      if p<FormatLength then TextOut:=TextOut+Format[p+1];
      inc(p,2);
      exit;
    end;

  if Format[p]='_' then
    begin
      if p<FormatLength then TextOut:=TextOut+' ';
      inc(p,2);
      exit;
    end;

  if Format[p]='"' then
  begin
    inc(p);
    while (p<=FormatLength) and (Format[p]<>'"') do
    begin
      TextOut:=TextOut+Format[p];
      inc(p);
    end;
    if p<=FormatLength then inc(p);
  end;
end;

procedure CheckDate(var RegionalCulture: PFormatSettings; const V: Variant; const Format: UTF16String; const Dates1904: boolean; var p: integer;
var TextOut: UTF16String; var LastHour: boolean;var HasDate, HasTime: boolean);
const
  DateTimeChars=['C','D','W','M','Q','Y','H','N','S','T','A','P','/',':','.','\'];
  DChars=['C','D','Y'];
  TChars=['H','N','S'];
var
  Fmt: string;
  FormatLength: integer;
begin
  FormatLength := Length(Format);
  Fmt:='';
  while (p<=FormatLength) and (ord(Format[p])<255) and (Upcase(AnsiChar(Format[p])) in DateTimeChars) do
  begin
    if (Format[p] = '\') then inc(p);
    if p > FormatLength then exit;

    if (p > 2) and (Format[p] = '/') and (p + 2 <= FormatLength)
    and ((Format[p-1] = 'M') or (Format[p-1] = 'm'))
    and ((Format[p-2] = 'A') or (Format[p-2] = 'a'))
    and ((Format[p+1] = 'P')  or (Format[p+1] = 'p'))
    and ((Format[p+2] = 'M')  or (Format[p+2] = 'm')) then
    begin             //AM/PM, must be changed to AMPM
      HasTime := true;
      Fmt:=Fmt + 'PM';
      inc (p, 3);
      continue;
    end;


    if (UpCase(AnsiChar(Format[p])) in DChars)or
       (not LastHour and (UpCase(AnsiChar(Format[p]))='M')) then HasDate:=true;
    if (UpCase(AnsiChar(Format[p])) in TChars)or
       (LastHour and (UpCase(AnsiChar(Format[p]))='M')) then HasTime:=true;

    if (UpCase(AnsiChar(Format[p]))='H') then LastHour:=true;
    if LastHour and (UpCase(AnsiChar(Format[p]))='M') then
    begin
      while (p<=FormatLength) and (UpCase(AnsiChar(Format[p]))='M') do
      begin
        Fmt:=Fmt+'n';
        inc(p);
      end;
      LastHour:=false;
    end else
    begin
      Fmt:=Fmt+Format[p];
      inc(p);
    end;
  end;

  EnsureAMPM(RegionalCulture);

  if Fmt<>'' then TextOut:=TextOut+TryFormatDateTime1904(Fmt,v, Dates1904, RegionalCulture^);
end;

procedure CheckNumber( V: Variant; const NegateValue: Boolean; const wFormat: UTF16String; var p: integer; var TextOut: UTF16String);
const
  NumberChars=['0','#','.',',','e','E','+','-','%','\','?','*'];
var
  Fmt: string;
  Format : string;
  FormatLength: integer;
begin
  Format := wFormat;
  FormatLength := Length(Format);
  Fmt:='';
  while (p<=FormatLength) and (ord(wFormat[p])<255) and (AnsiChar(Format[p]) in NumberChars) do
  begin
    if Format[p]='%' then V:=V*100;
    if (Format[p] = '\') then inc(p);
    if (p <= FormatLength) then
    begin
      if (Format[p] = '?') then Fmt:=Fmt+'#'
      else if (Format[p] = '*') then
      begin
        if (p<Length(Format)) then Fmt := Fmt + Format[p + 1];
        inc(p);
      end
      else Fmt:=Fmt+Format[p];
      inc(p);
    end;
  end;

  if (NegateValue) and (v < 0) then v := -v;
  if Fmt<>'' then TextOut:=TextOut+FormatFloat(Fmt,v);
end;

procedure CheckText(const V: Variant; const Format: UTF16String; var p: integer; var TextOut: UTF16String);
begin
  if p>Length(Format) then exit;
  if Format[p]='@' then
  begin
    TextOut:=TextOut+v;
    inc(p);
  end;
end;


function FormatNumber(const V: Variant; const NegateValue: Boolean; const Format: UTF16String; const Dates1904: boolean; var Color: integer;var HasDate, HasTime: boolean): UTF16String;
var
  p, p1: integer;
  LastHour: boolean;
  FormatLength: integer;
  RegionalCulture: PFormatSettings;
begin
  FormatLength := Length(Format);

  RegionalCulture := GetDefaultLocaleFormatSettings;
  CheckColor(Format, Color, p);
  Result:='';  LastHour:=false;
  while p<=FormatLength do
  begin
    p1:=p;
    CheckRegionalSettings(Format, RegionalCulture, p, Result, false);
    CheckOptional(V, Format, p, Result);
    CheckLiteral (V, Format, p, Result);
    CheckDate    (RegionalCulture, V, Format, Dates1904, p, Result, LastHour, HasDate, HasTime);
    CheckNumber  (V, NegateValue, Format, p, Result);
    if p1=p then //not found
    begin
      if (NegateValue and V < 0) then Result := -V  //Format number is always called with a numeric arg
      else Result:=V;
      exit;
    end;
  end;
end;

function FormatText(const V:Variant; Format: UTF16String; var Color: integer):UTF16String;
var
  SectionCount: integer;
  ts: integer;
  SupressNegativeSign: Boolean;
  Sections: WideStringArray;
  p: integer;
  p1: integer;
  FormatLength: integer;
  NewColor: integer;
begin
  FormatLength := Length(Format);

   //Numbers/dates and text formats can't be on the same format string. It is a number XOR a date XOR a text
  Sections := GetSections(Format, 0, ts, SectionCount, SupressNegativeSign);
  if SectionCount < 4 then
  begin
    Format := Sections[0];
    if (Pos('@', Format) <= 0) then  //everything is ignored here.
      begin
        NewColor:=Color;
        CheckColor(Format, NewColor, p);
        if (p > Length(Format)) or (UpperCase(copy(Format, p, length(Format))) = 'GENERAL')
            then Color := NewColor; //Excel only uses the color if the format is empty or has an "@".
        Result := v;
        exit;
      end;
  end
  else
  begin
    Format := Sections[3];
  end;

  CheckColor(Format, Color, p);
  Result:='';
  while p<=FormatLength do
  begin
    p1:=p;
    CheckOptional(V, Format, p, Result);
    CheckLiteral (V, Format, p, Result);
    CheckText    (V, Format, p, Result);
    if p1=p then //not found
    begin
      Result:=V;
      exit;
    end;
  end;
end;

function XlsFormatValueEx(const V: variant; Format: UTF16String; const Dates1904: boolean; var Color: Integer; out HasDate, HasTime: boolean): UTF16String;
var
  SectionMatches: Boolean;
  SupressNegativeSign: Boolean;
  FormatSection: UTF16String;
begin
  HasDate:=false;
  HasTime:=false;
  
  if VarIsNull(v) or VarIsClear(v) then begin; Result := ''; exit; end;
  
  if Format='' then  //General
  begin
    Result:= VariantToString(v);
    exit;
  end;

  //This is slow. We will do it in checkdate.
  //Format:=StringReplaceSkipQuotes(Format,'AM/PM','AMPM'); //Format AMPM is equivalent to AM/PM on delphi

  case VarType(V) of
    varByte,
    varSmallint,
    varInteger,
    varSingle,
    varDouble,
   {$IFDEF FLX_HASCUSTOMVARIANTS} varInt64,{$ENDIF} //Delphi 6 or above
    varCurrency : begin
                    FormatSection := GetSection(Format, V, SectionMatches, SupressNegativeSign);
                    if not SectionMatches then  //This is Excel2007 way. Older version would show an empty cell.
                    begin Result := '###################'; exit; end;

                    if Pos('[$-F800]', UpperCase(FormatSection)) > 0 then  //This means format with long date from regional settings. This is new on Excel 2002
                    begin
                      Result := TryFormatDateTime1904(LongDateFormat, V, Dates1904);
                      HasDate := true;
                      exit;
                    end;
                    if Pos('[$-F400]', UpperCase(FormatSection)) > 0 then  //This means format with long hour from regional settings. This is new on Excel 2002
                    begin
                      Result := TryFormatDateTime1904(LongTimeFormat, V, Dates1904);
                      HasTime := true;
                      exit;
                    end;

                    Result := FormatNumber(V, SupressNegativeSign, FormatSection, Dates1904, Color, HasDate, HasTime);
                  end;
    varDate     : begin
                    FormatSection := GetSection(Format, V, SectionMatches, SupressNegativeSign);
                    if not SectionMatches then  //This is Excel2007 way. Older version would show an empty cell.
                    begin Result := '###################'; exit; end;

                    if Pos('[$-F800]', UpperCase(FormatSection)) > 0 then  //This means format with long date from regional settings. This is new on Excel 2002
                    begin
                      Result := TryFormatDateTime1904(LongDateFormat, V, Dates1904);
                      HasDate := true;
                      exit;
                    end;
                    if Pos('[$-F400]', UpperCase(FormatSection)) > 0 then  //This means format with long hour from regional settings. This is new on Excel 2002
                    begin
                      Result := TryFormatDateTime1904(LongTimeFormat, V, Dates1904);
                      HasTime := true;
                      exit;
                    end;

                    if V<0 then Result:='###################' else //Negative dates are shown this way
                    Result := FormatNumber(V, SupressNegativeSign, FormatSection, Dates1904, Color, HasDate, HasTime);
                  end;
    varOleStr,
    varStrArg,
    {$IFDEF DELPHI2008UP}
    varUString,
    {$ENDIF}
    varString   : Result:=FormatText(V,Format, Color);

    varBoolean	: if V then Result:=TxtTrue else Result:=TxtFalse;

    else Result:= VariantToString(V);
  end; //case
end;

function XlsFormatValue(const V: variant; const Format: UTF16String; var Color: Integer): UTF16String;
var
  HasDate, HasTime: boolean;
begin
  Result:=XlsFormatValueEx(V, Format, false, Color, HasDate, HasTime);
end;

function XlsFormatValue1904(const V: variant; const Format: UTF16String; const Dates1904: boolean; var Color: Integer): UTF16String;
var
  HasDate, HasTime: boolean;
begin
  Result:=XlsFormatValueEx(V, Format, Dates1904, Color, HasDate, HasTime);
end;

function HasXlsDateTime(const Format: UTF16String; out HasDate, HasTime: boolean): boolean;
var
  Color: integer;
begin
  Color := -1;
  XlsFormatValueEx(10, Format, false, Color, HasDate, HasTime);
  Result:=HasDate or HasTime;
end;

end.