excelmaskii2.pas

一个经典的读写Excel的控件

unit ExcelMaskII2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2002 Lars Arvidsson, Axolot Data               *******
*******                                                                  *******
******* email: [e-mail]                                     *******
******* URL:   http://www.axolot.com                                     *******
********************************************************************************
** Users of the XLSReadWriteII component must accept the following            **
** disclaimer of warranty:                                                    **
**                                                                            **
** XLSReadWriteII is supplied as is. The author disclaims all warranties,     **
** expressedor implied, including, without limitation, the warranties of      **
** merchantability and of fitness for any purpose. The author assumes no      **
** liability for damages, direct or consequential, which may result from the  **
** use of XLSReadWriteII.                                                     **
********************************************************************************
}

{$B-}

interface

uses SysUtils, Classes, Graphics, XLSUtils2, XLSRWIIResourceStrings2;

type TMaskEntity = (meNone,meLitteral,meString,mePlace,meSpace,meZero,
                    // Date
                    meYear2,meYear4,
                    meMonthDig1,meMonthDig2,meMonthShort,meMonthName,meMonthChar,
                    meDayDig1,meDayDig2,meDayShort,meDayName,
                    // Time
                    meHourDig1,meHourDig2,
                    meHourDig1AmPm,meHourDig2AmPm,
                    meHourElapsed,
                    meMinuteDig1,meMinuteDig2,
                    meMinuteElapsed,
                    meSecondDig1,meSecondDig2,
                    meSecondElapsed,
                    meStrAmPmUpp,meStrAmPmLow,meStrap,
                    // Control
                    meDecimalPos,
                    mePercentPos,
                    meFirstDigitPlace
                    );

type TMaskFlag = (mfGeneral,mfThousand,mfDecimals,mfPercent,mfScientific,mfIsDateTime,mfZero);
type TMaskFlags = set of TMaskFlag;

type PMaskData = ^TMaskData;
     TMaskData = record
     Entity: TMaskEntity;
     case integer of
       0: (C: char);
       1: (S: PChar);
     end;

type PFormatData = ^TFormatData;
     TFormatData = record
     Data: TList;
     Color: TColor;
     Flags: TMaskFlags;
     DataDecimalPos: integer;
     DecimalCount: integer;
     Div1000Cnt: integer;
     end;

type TExcelMask = class (TObject)
private
    FMask: string;
    FIndex: integer;
    Formats: array[0..3] of PFormatData;

    procedure SetMask(const Value: string);
    procedure AddMask(Index: integer; const Value: string);
    procedure ClearData;
    function  AddEntity(Index: integer; E: TMaskEntity): PMaskData;
protected
    function FormatNumberDateTime(FD: PFormatData; Value: double): string;
    function FormatNumberNumber(FD: PFormatData; Value: double): string;
public
    destructor Destroy; override;
    function FormatNumber(Value: double): string;
    function Color(Value: double): TColor;
    function IsDateTime: boolean;

    property Mask: string read FMask write SetMask;
    property Index: integer read FIndex write FIndex;
    end;

function XLSGetCurrencyFormat(DecStr,ThStr: string): string;

implementation

{ TExcelMask }

function IntPower(Base: double; Exponent: Integer): double;
asm
        mov     ecx, eax
        cdq
        fld1
        xor     eax, edx
        sub     eax, edx
        jz      @@3
        fld     Base
        jmp     @@2
@@1:    fmul    ST, ST
@@2:    shr     eax,1
        jnc     @@1
        fmul    ST(1),ST
        jnz     @@1
        fstp    st
        cmp     ecx, 0
        jge     @@3
        fld1
        fdivrp
@@3:
        fwait
end;

function Power(Base, Exponent: double): double;
begin
  if Exponent = 0.0 then
    Result := 1.0
  else if (Base = 0.0) and (Exponent > 0.0) then
    Result := 0.0
  else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
    Result := IntPower(Base, Integer(Trunc(Exponent)))
  else
    Result := Exp(Exponent * Ln(Base))
end;

function XLSGetCurrencyFormat(DecStr,ThStr: string): string;
begin
  Result := CurrencyString;
  case CurrencyFormat of
    0: Result := CurrencyString + ' ' + ThSTr + DecStr;
    1: Result := ThStr + DecStr + ' ' + CurrencyString;
    2: Result := CurrencyString + '  ' + ThStr + DecStr;
    3: Result := ThSTr + DecStr + '  ' + CurrencyString;
  end;
  case NegCurrFormat of
     0: Result := Result + ';(' + CurrencyString + ThStr + DecStr + ')';
     1: Result := Result + ';-' + CurrencyString + ThStr + DecStr;
     2: Result := Result + ';' + CurrencyString + '-' + ThStr + DecStr;
     3: Result := Result + ';' + CurrencyString + ThStr + DecStr + '-';
     4: Result := Result + ';(' + ThStr + DecStr + CurrencyString + ')';
     5: Result := Result + ';-' + ThStr + DecStr + CurrencyString;
     6: Result := Result + ';' + ThStr + DecStr + '-' + CurrencyString;
     7: Result := Result + ';' + ThStr + DecStr + CurrencyString + '-';
     8: Result := Result + ';-' + ThStr + DecStr + ' ' + CurrencyString;
     9: Result := Result + ';-' + CurrencyString + ' ' + ThSTr + DecStr;
    10: Result := Result + ';' + ThStr + DecStr + ' ' + CurrencyString + '-';
    11: Result := Result + ';' + CurrencyString + ' ' + ThStr + DecStr + '-';
    12: Result := Result + ';' + CurrencyString + ' -' + ThSTr + DecStr;
    13: Result := Result + ';' + ThSTr + DecStr + '- ' + CurrencyString;
    14: Result := Result + ';(' + CurrencyString + ' ' + ThStr + DecStr + ')';
    15: Result := Result + ';(' + ThStr + DecStr + ' ' + CurrencyString + ')';
  end;
end;

destructor TExcelMask.Destroy;
begin
  ClearData;
  inherited Destroy;
end;

procedure TExcelMask.ClearData;
var
  i,j: integer;
begin
  for j := 0 to High(Formats) do begin
    if Formats[j] <> Nil then with Formats[j]^ do begin
      for i := 0 to Data.Count - 1 do begin
        if PMaskData(Data[i]).Entity = meString then
          StrDispose(PMaskData(Data[i]).S);
        Dispose(Data[i]);
      end;
      Data.Clear;
      Data.Free;
    end;
  end;
  for i := 0 to High(Formats) do begin
    Dispose(Formats[i]);
    Formats[i] := Nil;
  end;
end;

function TExcelMask.IsDateTime: boolean;
begin
  if Formats[0] <> Nil then
    Result := mfIsDateTime in Formats[0].Flags
  else
    Result := False;
end;

function TExcelMask.AddEntity(Index: integer; E: TMaskEntity): PMaskData;
begin
  New(Result);
  Result.Entity := E;
  Formats[Index].Data.Add(Result);
end;

procedure TExcelMask.SetMask(const Value: string);
var
  i,j,p: integer;
  SepPos: array[0..4] of integer;
  InsideQuotes: boolean;
  S: string;
begin
  if Length(Value) > 255 then
    raise Exception.Create(ersFmtStringLenGT255);
  FMask := Value;
  ClearData;
  InsideQuotes := False;
  j := 0;
  for i := 1 to Length(FMask) do begin
    if FMask[i] = '"' then
      InsideQuotes := not InsideQuotes;
    if (FMask[i] = ';') and not InsideQuotes then begin
      SepPos[j] := i - 1;
      Inc(j);
      if j > (High(SepPos) - 1) then
        Break;
    end;
  end;
  SepPos[j] := Length(FMask) + 1;
  if j > 3 then
    j := 3;
  p := 1;
  for i := 0 to j do begin
    S := Copy(FMask,p,SepPos[i] - p + 1);
    if S <> '' then
      AddMask(i,S);
    p := SepPos[i] + 2;
  end;
end;

procedure TExcelMask.AddMask(Index: integer; const Value: string);
var
  i,j: integer;
  C: char;
  pMD, LastTimeMD: PMaskData;
  S: string;
begin
  New(Formats[Index]);
  with Formats[Index]^ do begin
    Data := TList.Create;
    Flags := [];
    if Index = 2 then
      Flags := Flags + [mfZero];
    Color := clBlack;
    DecimalCount := 0;
    DataDecimalPos := -1;
    Div1000Cnt := 0;
    LastTimeMD := Nil;
    i := 1;
    while i <= Length(Value) do begin
      case Value[i] of
        '@':
        begin
          AddEntity(Index,meNone);
          Flags := [mfGeneral];
        end;
        '#':
        begin
          AddEntity(Index,mePlace);
          if mfDecimals in Flags then
            Inc(DecimalCount);
          Div1000Cnt := 0;
        end;
        '?':
        begin
          AddEntity(Index,meSpace);
          Div1000Cnt := 0;
        end;
        '0':
        begin
          AddEntity(Index,meZero);
          if mfDecimals in Flags then
            Inc(DecimalCount);
          Div1000Cnt := 0;
        end;
        'e','E': begin
          if (i < Length(Mask)) and (Mask[i + 1] in ['-','+']) then begin
            Inc(i);
            AddEntity(Index,meNone);
            Flags := Flags + [mfScientific];
          end
          else begin
            pMD := AddEntity(Index,meLitteral);
            pMD.C := Value[i];
          end;
        end;
        '%':
        begin
          Flags := Flags + [mfPercent];
          AddEntity(Index,mePercentPos);
        end;
        '\':
        begin
          Inc(i);
          if i <= Length(Mask) then begin
            pMD := AddEntity(Index,meLitteral);
            pMD.C := Value[i];
          end;
        end;
        '*': ;
        '_':
        begin
          Inc(i);
          if i <= Length(Mask) then begin
            pMD := AddEntity(Index,meLitteral);
            pMD.C := ' ';
          end;
        end;
        '"':
        begin
          j := i + 1;
          Inc(i);
          while (i <= Length(Value)) and (Value[i] <> '"') do
            Inc(i);
          if i <= Length(Value) then begin
            pMD := AddEntity(Index,meString);
            pMD.S := StrAlloc(i - j + 1);
            StrPCopy(pMD.S,Copy(Value,j,i - j));
          end;
        end;
        '.':
        begin
          Flags := Flags + [mfDecimals];
          AddEntity(Index,meDecimalPos);
          DataDecimalPos := Data.Count;
        end;
        ',': begin
          Flags := Flags + [mfThousand];
          Inc(Div1000Cnt);
        end;
        '[':
        begin
          j := i + 1;
          Inc(i);
          while (i <= Length(Value)) and (Value[i] <> ']') do
            Inc(i);
          if i <= Length(Value) then begin
            S := Uppercase(Copy(Value,j,i - j));
            if (S = 'H') or (S = 'HH') then
              AddEntity(Index,meHourElapsed)
            else if (S = 'M') or (S = 'MM') then
              AddEntity(Index,meMinuteElapsed)
            else if (S = 'S') or (S = 'SS') then
              AddEntity(Index,meSecondElapsed)
            else if S = 'BLACK'   then Color := clBlack
            else if S = 'CYAN'    then Color := clFuchsia
            else if S = 'MAGENTA' then Color := clPurple
            else if S = 'WHITE'   then Color := clWhite
            else if S = 'BLUE'    then Color := clBlue
            else if S = 'GREEN'   then Color := clGreen
            else if S = 'RED'     then Color := clRed
            else if S = 'YELLOW'  then Color := clYellow;
          end;
          if (Data.Count > 0) and (PMaskData(Data[Data.Count - 1]).Entity in [meHourElapsed,meMinuteElapsed,meSecondElapsed]) then
            Flags := Flags + [mfIsDateTime];
        end;
        'Y','M','D','y','m','d','h','s':
        begin
          Flags := Flags + [mfIsDateTime];
          S := Lowercase(Value);
          C := S[i];