tmsuxlsxf.pas

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

unit tmsUXlsXF;
{$INCLUDE ..\FLXCOMPILER.INC}

interface
uses Classes, SysUtils, tmsUXlsBaseRecords, tmsUXlsBaseRecordLists, tmsXlsMessages,
     tmsUFlxFormats, tmsUXlsStrings, tmsUFlxMessages;

type
  TXFDat=packed record
    Font: word;       //0
    Format: word;     //2
    Options4: word;    //4
    Options6: word;  //6
    Options8: word;  //8
    Options10: word;  //10
    Options12: word;     //12
    Options14: LongWord; //14
    Options18: Word; //18
  end;
  PXFDat=^TXFDat;

  TFontRecordList=class;
  TFormatRecordList=class;

  TXFRecord=class(TBaseRecord)
  public
    function CellPattern: integer;
    function CellFgColorIndex: integer;
    function CellBgColorIndex: integer;

    function FontIndex: integer;
    function FormatIndex: integer;
    function GetActualFontIndex(const FontList: TFontRecordList): integer;

    function GetBorderStyle(const aPos: integer; const FirstBit: byte):TFlxBorderStyle;
    function GetBorderColorIndex(const aPos: integer; const FirstBit: byte):integer;
    function GetBorderStyleExt(const aPos: integer; const FirstBit: byte):TFlxBorderStyle;
    function GetBorderColorIndexExt(const aPos: integer; const FirstBit: byte):integer;

    function DiagonalStyle: TFlxDiagonalBorder;

    function VAlign: TVFlxAlignment;
    function HAlign: THFlxAlignment;

    procedure FillMisc(out Locked, Hidden: boolean;out Parent: integer;
                       out WrapText, ShrinkToFit: boolean; out Rotation: byte;
                       out Indent: byte);

    constructor CreateFromFormat(const Fmt: TFlxFormat; const FontList: TFontRecordList; const FormatList: TFormatRecordList);
    function FlxFormat(const FontList: TFontRecordList; const FormatList: TFormatRecordList): TFlxFormat;
    procedure FillUsedColors(const UsedColors: BooleanArray; const FontList: TFontRecordList);

    function Rotation: integer;
    function WrapText: boolean;
  end;

  TXFRecordList= class(TBaseRecordList)  //Items are TXFRecord
  {$INCLUDE TXFRecordListHdr.inc}
  public
    function FindFormat(const XF: TXFRecord; out Index: integer): boolean;
    function GetUsedColors(const ColorCount: integer; const FontList: TFontRecordList): BooleanArray;
  end;

//------------------------------------------------- FONT
  TFontDat=packed record
    Height: word;
    GrBit: word;
    ColorIndex: word;
    BoldStyle: word;
    SuperSub: word;
    Underline: byte;
    Family: byte;
    CharSet: byte;
    Reserved: byte;
    //Font name is not included
  end;
  PFontDat=^TFontDat;

  TFontRecord= class(TBaseRecord)
    function Name: UTF16String;
    function Height: integer;
    function ColorIndex: integer;
    function Family: byte;
    function Charset: byte;

    function Style: SetOfTFlxFontStyle;
    function Underline: TFlxUnderline;

    constructor CreateFromFlxFont(const aFont: TFlxFont);
  public
    function FlxFont: TFlxFont;
  end;

  TFontRecordList=class(TBaseRecordList)  //Items are TFontRecord
  {$INCLUDE TFontRecordListHdr.inc}
  public
    function AddFont(const aFont: TFlxFont): integer;
  end;

///------------------------------------------------ Style
  TStyleRecord= class(TBaseRecord)
  end;

//------------------------------------------------- FORMAT
  TFormatRecord= class(TBaseRecord)
  public
    function FormatId: integer;
    function Value: UTF16String;
    constructor CreateFromData(const Fmt: UTF16String; const NewID: integer);
  end;

  TFormatRecordList=class(TBaseRecordList)
  private
    function GetFormat(FormatId: integer): UTF16String;  //Items are TFormatRecord
  {$INCLUDE TFormatRecordListHdr.inc}
  public
    property Format[index: integer]: UTF16String read GetFormat; default;
    function AddFormat(const Fmt: UTF16String): integer;
  end;
implementation
  {$INCLUDE TXFRecordListImp.inc}
  {$INCLUDE TFontRecordListImp.inc}
  {$INCLUDE TFormatRecordListImp.inc}

const
  XlsBuiltInFormatsUs: array[0..49] of UTF16String=
  ('', '0', '0.00','#,##0','#,##0.00',                              //0..4
   '', '', '', '',                                                   //5..8  Contained in file
   '0%','0.00%','0.00E+00','?/?','# ??/??',                         //9..13
   'mm/dd/YYYY','DD-MMM-YY','DD-MMM','MMM-YY',                      //14..17
   'h:mm AM/PM','h:mm:ss AM/PM','hh:mm','hh:mm:ss',                 //18..21
   'mm/dd/YYYY hh:mm',                                              //22
   '','','','','','','','','','','','','','',                       //23..36 Reserved
   '#,##0 _$;-#,##0 _$','#,##0 _$;[Red]-#,##0 _$',              //37..38
   '#,##0.00 _$;-#,##0.00 _$','#,##0.00 _$;[Red]-#,##0.00 _$',  //39..40
   '','','','',                                                     //41..44 contained in file
   'mm:ss','[h]:mm:ss','mm:ss,0','##0.0E+0','@'                 //45..49
  );

function XlsBuiltInFormats(const z: integer): UTF16String;
var
  i: integer;
  s, Sep, Hour: UTF16String;
  c: UTF16Char;
begin
  if (z = 14) then //Regional date.
  begin
      s := ShortDateFormat;
      Sep := DateSeparator;
      //It looks Excel will only show 3 formats:
      // m/d/y
      // d/m/y
      // y/m/d
      //depending on which thing you begin. yy and yyyy are both allowed.

      for i:=1 to Length(s) do
      begin
          c := s[i];
          if (c='y') or (c = 'Y') then begin; Result:= 'YYYY' + Sep + 'mm' + Sep + 'dd'; exit; end;
          if (c='m') or (c = 'M') then begin; Result:= 'mm' + Sep + 'dd' + Sep + 'YYYY'; exit; end;
          if (c='d') or (c = 'D') then begin; Result:= 'dd' + Sep + 'mm' + Sep + 'YYYY'; exit; end;
      end;
  end;
  if (z = 22) then //Regional date time
  begin
      s := ShortDateFormat;
      Sep := DateSeparator;
      //It looks Excel will only show 3 formats:
      // m/d/y
      // d/m/y
      // y/m/d
      //depending on which thing you begin. yy and yyyy are both allowed.

      Hour := ' hh' + TimeSeparator + 'mm';

      for i:=1 to Length(s) do
      begin
          c := s[i];
          if (c='y') or (c = 'Y') then begin; Result:= 'YYYY' + Sep + 'mm' + Sep + 'dd' + Hour; exit; end;
          if (c='m') or (c = 'M') then begin; Result:= 'mm' + Sep + 'dd' + Sep + 'YYYY' + Hour; exit; end;
          if (c='d') or (c = 'D') then begin; Result:= 'dd' + Sep + 'mm' + Sep + 'YYYY' + Hour; exit; end;
      end;
  end;

  Result:= XlsBuiltInFormatsUs[z];
end;

{ TXFRecord }

function TXFRecord.CellBgColorIndex: integer;
begin
  Result:= (PXFDat(Data).Options18 and $3F80) shr 7 -7;
end;

function TXFRecord.CellFgColorIndex: integer;
begin
  Result:= PXFDat(Data).Options18 and $7F -7;
end;

function TXFRecord.CellPattern: integer;
begin
  Result:= PXFDat(Data).Options14 and $FC000000 shr 26;
end;

function BoolToBit(const Value: boolean; const ofs: integer): integer;
begin
  if Value then Result:=1 shl ofs else Result:=0;
end;

constructor TXFRecord.CreateFromFormat(const Fmt: TFlxFormat; const FontList: TFontRecordList; const FormatList: TFormatRecordList);
var
  TempData: PXFDat;
  bl, br, bb, bt: integer;
begin
  GetMem (TempData, SizeOf(TXFDat));
  try
    TempData.Font:= FontList.AddFont(Fmt.Font);
    TempData.Format:=FormatList.AddFormat(Fmt.Format);
    TempData.Options4:= BoolToBit(Fmt.Locked,0)+
                                  BoolToBit(Fmt.Hidden,1)+
                                  0 shl 2+ //Cell style
                                  0 shl 3+ //123 lotus
    //                              (Fmt.Parent shl 4) and $FFF0;
                                  0;  //No parents... they are too confusing

    TempData.Options4:=TempData.Options4 and not $0004; //not style
    TempData.Options6:=integer(Fmt.HAlignment)+
                       BoolToBit(Fmt.WrapText, 3)+
                       integer(Fmt.VAlignment)shl 4+
                       (Fmt.Rotation shl 8)and $FF00;

    TempData.Options8:=Fmt.Indent and $F+
                       BoolToBit(Fmt.ShrinkToFit, 4)+
                       0+ //mergecell
                       0+ //readingOrder
                       $0400+ //fmt not equal to parent
                       $0800+ //Font not equal to parent
                       $1000+$2000+$4000+$8000; //Many things not equal to parent...
                       //PENDING: agregar

    TempData.Options10:=integer(Fmt.Borders.Left.Style)+
                        integer(Fmt.Borders.Right.Style) shl 4+
                        integer(Fmt.Borders.Top.Style) shl 8+
                        integer(Fmt.Borders.Bottom.Style) shl 12;

    bl:=(Fmt.Borders.Left.ColorIndex+7) and $7F;
    if bl<8 then bl:=8; if bl>56+8 then bl:=56+8;
    br:=(Fmt.Borders.Right.ColorIndex+7) and $7F;
    if br<8 then br:=8; if br>56+8 then br:=56+8;
    TempData.Options12:=bl +
                        (br) shl 7+
                        integer(Fmt.Borders.DiagonalStyle) shl 14;

    bt:=(Fmt.Borders.Top.ColorIndex+7) and $7F;
    if bt<8 then bt:=8; if bt>56+8 then bt:=56+8;
    bb:=(Fmt.Borders.Bottom.ColorIndex+7) and $7F;
    if bb<8 then bb:=8; if bb>56+8 then bb:=56+8;
    TempData.Options14:= bt+
                         bb shl 7+
                        ((Fmt.Borders.Diagonal.ColorIndex+7) and $7F) shl 14+
                        integer(Fmt.Borders.Diagonal.Style) shl 21+
                        (Fmt.FillPattern.Pattern-1) shl 26;

    TempData.Options18:= (Fmt.FillPattern.FgColorIndex+7) and $7F +
                         ((Fmt.FillPattern.BgColorIndex+7) and $7F) shl 7+
                         0; //Attached to pivot table


    inherited Create(xlr_XF, PArrayOfByte(TempData), SizeOf(TXFDat));
  except
    FreeMem(TempData);
    raise;
  end;
end;

function TXFRecord.DiagonalStyle: TFlxDiagonalBorder;
begin
  Result:=TFlxDiagonalBorder((GetLongWord(Data,12) shr 14) and  3);
end;

procedure TXFRecord.FillMisc(out Locked, Hidden: boolean;
  out Parent: integer; out WrapText, ShrinkToFit: boolean; out Rotation, Indent: byte);
begin
  Locked:=PXFDat(Data).Options4 and $1 = $1;
  Hidden:=PXFDat(Data).Options4 and $2 = $2;
  Parent:=PXFDat(Data).Options4 and $FFF0;

  WrapText:= PXFDat(Data).Options6 and $8 = $8;

  ShrinkToFit:= PXFDat(Data).Options8 and $10 = $10;

  Rotation:= Hi(PXFDat(Data).Options6 and $FF00);
  Indent:= PXFDat(Data).Options8 and $F;

end;

function TXFRecord.GetActualFontIndex(const FontList: TFontRecordList): integer;
begin
  Result := FontIndex;
  if Result >= 4 then
    Dec(Result);

  if (Result < 0) or (Result >= FontList.Count) then
    Result := 0;
end;

procedure TXFRecord.FillUsedColors(const UsedColors: BooleanArray; const FontList: TFontRecordList);
var
  i: integer;
  bs: TFlxBorderStyle;
  Pattern: TFlxPatternStyle;
begin
  bs := GetBorderStyle(10, 0);
  if bs <> fbs_None then
  begin
    i := GetBorderColorIndex(12, 0);
    if (i >= 0) and (i < Length(UsedColors)) then
      UsedColors[i] := true;

  end;

  bs := GetBorderStyle(10, 4);
  if bs <> fbs_None then
  begin
    i := GetBorderColorIndex(12, 7);
    if (i >= 0) and (i < Length(UsedColors)) then
      UsedColors[i] := true;

  end;

  bs := GetBorderStyle(11, 0);
  if bs <> fbs_None then
  begin
    i := GetBorderColorIndex(14, 0);
    if (i >= 0) and (i < Length(UsedColors)) then
      UsedColors[i] := true;

  end;

  bs := GetBorderStyle(11, 4);
  if bs <> fbs_None then
  begin
    i := GetBorderColorIndex(14, 7);
    if (i >= 0) and (i < Length(UsedColors)) then
      UsedColors[i] := true;

  end;

  bs := GetBorderStyleExt(14, 21);
  if bs <> fbs_None then
  begin
    i := GetBorderColorIndexExt(14, 14);
    if (i >= 0) and (i < Length(UsedColors)) then
      UsedColors[i] := true;

  end;

  Pattern := TFlxPatternStyle(CellPattern + 1);
  if Pattern <> 1 then
  begin
    i := CellFgColorIndex;
    if (i >= 0) and (i < Length(UsedColors)) then