home *** CD-ROM | disk | FTP | other *** search
/ Chip 2003 January / Chip_2003-01_cd1.bin / zkuste / delphi / kolekce / d567 / FLEXCEL.ZIP / FlexCel / UFlxNumberFormat.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-10-10  |  7.1 KB  |  268 lines
  1. unit UFlxNumberFormat;
  2.  
  3. interface
  4. uses SysUtils,
  5.   {$IFDEF ConditionalExpressions}{$if CompilerVersion >= 14} variants,{$IFEND}{$ENDIF} //Delphi 6 or above
  6.      UFlxMessages, Math;
  7.  
  8.   function XlsFormatValue(const V: variant; const Format: Widestring; var Color: Integer): Widestring;
  9.  
  10. /////////////////////////////////////////////////////////////////////////////////
  11. implementation
  12.  
  13. function FindFrom(const wc: WideChar; const w: WideString; const p: integer): integer;
  14. begin
  15.   Result:=pos(wc, copy(w, p, Length(w)))
  16. end;
  17.  
  18. function Section(const Index: byte; const Format: Widestring; var SectionExists: boolean):Widestring;
  19. //split the 4 sections of a format string
  20. var
  21.   i: integer;
  22.   aPos, TotalPos: integer;
  23. begin
  24.   aPos:=1; TotalPos:=1;
  25.   for i:=0 to Index-1 do
  26.     if aPos>0 then
  27.     begin
  28.       aPos:=FindFrom(';',Format, TotalPos);
  29.       inc(TotalPos, aPos);
  30.     end;
  31.  
  32.   SectionExists:=aPos>0;
  33.   if not SectionExists then TotalPos:=1;
  34.   Result:=copy(Format,TotalPos, FindFrom(';',Format+';', TotalPos)-1);
  35. end;
  36.  
  37. //we include this so we don't need to use graphics
  38. const
  39.   clBlack = $000000;
  40.   clGreen = $008000;
  41.   clRed = $0000FF;
  42.   clYellow = $00FFFF;
  43.   clBlue = $FF0000;
  44.   clFuchsia = $FF00FF;
  45.   clAqua = $FFFF00;
  46.   clWhite = $FFFFFF;
  47.  
  48.  
  49. procedure CheckColor(const Format: Widestring; var Color: integer; var p: integer);
  50. var
  51.   s: string;
  52.   IgnoreIt: boolean;
  53. begin
  54.   p:=1;
  55.   if (Length(Format)>0) and (Format[1]='[') and (pos(']', Format)>0) then
  56.   begin
  57.     IgnoreIt:=false;
  58.     s:=copy(Format,2,pos(']', Format)-2);
  59.     if s = 'Black'  then Color:=clBlack else
  60.     if s = 'Cyan'   then Color:=clAqua else
  61.     if s = 'Blue'   then Color:=clBlue else
  62.     if s = 'Green'  then Color:=clGreen else
  63.     if s = 'Magenta'then Color:=clFuchsia else
  64.     if s = 'Red'    then Color:=clRed else
  65.     if s = 'White'  then Color:=clWhite else
  66.     if s = 'Yellow' then Color:=clYellow
  67.     else IgnoreIt:=true;
  68.  
  69.     if not IgnoreIt then p:= Pos(']', Format)+1;
  70.   end;
  71. end;
  72.  
  73. procedure CheckOptional(const V: Variant; const Format: widestring; var p: integer; var TextOut: widestring);
  74. var
  75.   p2, p3: integer;
  76. begin
  77.   if p>Length(Format) then exit;
  78.   if Format[p]='[' then
  79.   begin
  80.     p2:=FindFrom(']', Format, p);
  81.     if (p<Length(Format))and(Format[p+1]='$') then //currency
  82.     begin
  83.       p3:=FindFrom('-', Format+'-', p);
  84.       TextOut:=TextOut + copy(Format, p+2, min(p2,p3)-3);
  85.     end;
  86.     Inc(p, p2);
  87.   end;
  88. end;
  89.  
  90. procedure CheckLiteral(const V: Variant; const Format: widestring; var p: integer; var TextOut: widestring);
  91. begin
  92.   if p>Length(Format) then exit;
  93.   if (ord(Format[p])<255) and (char(Format[p]) in[' ','$','(',')','!','^','&','''','┤','~','{','}','=','<','>']) then
  94.     begin
  95.       TextOut:=TextOut+Format[p];
  96.       inc(p);
  97.       exit;
  98.     end;
  99.  
  100.   if (Format[p]='\') or (Format[p]='*')then
  101.     begin
  102.       if p<Length(Format) then TextOut:=TextOut+Format[p+1];
  103.       inc(p,2);
  104.       exit;
  105.     end;
  106.  
  107.   if Format[p]='_' then
  108.     begin
  109.       if p<Length(Format) then TextOut:=TextOut+' ';
  110.       inc(p,2);
  111.       exit;
  112.     end;
  113.  
  114.   if Format[p]='"' then
  115.   begin
  116.     inc(p);
  117.     while (p<=Length(Format)) and (Format[p]<>'"') do
  118.     begin
  119.       TextOut:=TextOut+Format[p];
  120.       inc(p);
  121.     end;
  122.     if p<=Length(Format) then inc(p);
  123.   end;
  124. end;
  125.  
  126. procedure CheckDate(const V: Variant; const Format: widestring; var p: integer; var TextOut: widestring; var LastHour: boolean);
  127. const
  128.   DateChars=['C','D','W','M','Q','Y','H','N','S','T','A','P','/',':','.'];
  129. var
  130.   Fmt: string;
  131. begin
  132.   Fmt:='';
  133.   while (p<=Length(Format)) and (ord(Format[p])<255) and (Upcase(char(Format[p])) in DateChars) do
  134.   begin
  135.     if (UpCase(Char(Format[p]))='h') then LastHour:=true;
  136.     if LastHour and (UpCase(Char(Format[p]))='m') then
  137.     begin
  138.       while (p<=Length(Format)) and (UpCase(Char(Format[p]))='m') do
  139.       begin
  140.         Fmt:=Fmt+'n';
  141.         inc(p);
  142.       end;
  143.       LastHour:=false;
  144.     end else
  145.     begin
  146.       Fmt:=Fmt+Format[p];
  147.       inc(p);
  148.     end;
  149.   end;
  150.  
  151.   if Fmt<>'' then TextOut:=TextOut+FormatDateTime(Fmt,v);
  152. end;
  153.  
  154. procedure CheckNumber( V: Variant; const Format: widestring; var p: integer; var TextOut: widestring);
  155. const
  156.   NumberChars=['0','#','.',',','e','E','+','-','%'];
  157. var
  158.   Fmt: string;
  159. begin
  160.   Fmt:='';
  161.   while (p<=Length(Format)) and (ord(Format[p])<255) and (char(Format[p]) in NumberChars) do
  162.   begin
  163.     if Format[p]='%' then V:=V*100;
  164.     Fmt:=Fmt+Format[p];
  165.     inc(p);
  166.   end;
  167.  
  168.   if Fmt<>'' then TextOut:=TextOut+FormatFloat(Fmt,v);
  169. end;
  170.  
  171. procedure CheckText(const V: Variant; const Format: widestring; var p: integer; var TextOut: widestring);
  172. begin
  173.   if p>Length(Format) then exit;
  174.   if Format[p]='@' then
  175.   begin
  176.     TextOut:=TextOut+v;
  177.     inc(p);
  178.   end;
  179. end;
  180.  
  181.  
  182. function FormatNumber(const V: Variant; const Format: WideString; var Color: integer): WideString;
  183. var
  184.   p, p1: integer;
  185.   LastHour: boolean;
  186. begin
  187.   CheckColor(Format, Color, p);
  188.   Result:='';  LastHour:=false;
  189.   while p<=Length(Format) do
  190.   begin
  191.     p1:=p;
  192.     CheckOptional(V, Format, p, Result);
  193.     CheckLiteral (V, Format, p, Result);
  194.     CheckDate    (V, Format, p, Result, LastHour);
  195.     CheckNumber  (V, Format, p, Result);
  196.     if p1=p then //not found
  197.     begin
  198.       Result:=V;
  199.       exit;
  200.     end;
  201.   end;
  202. end;
  203.  
  204. function FormatText(const V:Variant; Format: WideString; var Color: integer):Widestring;
  205. var
  206.   SectionExists: boolean;
  207.   p, p1: integer;
  208. begin
  209.   Format:=Section(3, Format, SectionExists);
  210.   if not SectionExists and (Pos('@', Format)=0) then
  211.   begin
  212.     Result:=v;
  213.     exit;
  214.   end;
  215.  
  216.   CheckColor(Format, Color, p);
  217.   Result:='';
  218.   while p<=Length(Format) do
  219.   begin
  220.     p1:=p;
  221.     CheckOptional(V, Format, p, Result);
  222.     CheckLiteral (V, Format, p, Result);
  223.     CheckText    (V, Format, p, Result);
  224.     if p1=p then //not found
  225.     begin
  226.       Result:=V;
  227.       exit;
  228.     end;
  229.   end;
  230. end;
  231.  
  232. function XlsFormatValue(const V: variant; const Format: Widestring; var Color: Integer): Widestring;
  233. var
  234.   SectionExists: boolean;
  235. begin
  236.   if Format='' then  //General
  237.   begin
  238.     Result:=v;
  239.     exit;
  240.   end;
  241.   
  242.   case VarType(V) of
  243.     varByte,
  244.     varSmallint,
  245.     varInteger,
  246.     varSingle,
  247.     varDouble,
  248.    {$IFDEF ConditionalExpressions}{$if CompilerVersion >= 14} varInt64,{$IFEND}{$ENDIF} //Delphi 6 or above
  249.  
  250.     varCurrency : if V>0 then Result:=FormatNumber(V, Section(0,Format,SectionExists), Color) else
  251.                   if V<0 then Result:=FormatNumber(-V, Section(1,Format,SectionExists), Color) else
  252.                   Result:=FormatNumber(V, Section(2,Format,SectionExists), Color);
  253.  
  254.     varDate     : if V>0 then Result:=FormatNumber(V, Section(0,Format,SectionExists), Color) else
  255.                   if V<0 then Result:='###################' else //Negative dates are shown this way
  256.                   Result:=FormatNumber(V, Section(2,Format,SectionExists), Color);
  257.     varOleStr,
  258.     varStrArg,
  259.     varString   : Result:=FormatText(V,Format, Color);
  260.  
  261.     varBoolean    : if V then Result:=TxtTrue else Result:=TxtFalse;
  262.  
  263.     else Result:=V;
  264.   end; //case
  265. end;
  266.  
  267. end.
  268.