condfmt2.pas

一个经典的读写Excel的控件

unit CondFmt2;

{
********************************************************************************
******* XLSReadWriteII V2.00                                             *******
*******                                                                  *******
******* Copyright(C) 1999,2004 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 Classes, SysUtils, BIFFRecsII2, XLSNames2, CellFormats2, XLSFonts2,
     XLSUtils2, CellAreas2, FormulaHandler2, XLSStream2, MoveCopy2;

type TConditionOperator = (coNoComparision,coBetween,coNotBetween,coEqual,coNotEqual,coGreater,coLess,coGreateEqual,coLessEqual);

type
//: Font for conditional formats.
    TCondFmtFont = class(TPersistent)
private
     FCFFont: TCFFont;
     FAssigned: boolean;

     function  GetColor: TExcelColor;
     function  GetFontStyle: TXFontStyles;
     function  GetHeight20: longword;
     function  GetSubSuperscript: TXSubSuperscript;
     function  GetUnderline: TXUnderline;
     procedure SetColor(const Value: TExcelColor);
     procedure SetFontStyle(const Value: TXFontStyles);
     procedure SetHeight20(const Value: longword);
     procedure SetSubSuperscript(const Value: TXSubSuperscript);
     procedure SetUnderline(const Value: TXUnderline);
     procedure SetRec(CFFont: PCFFont);
protected
     property Assigned: boolean read FAssigned;
public
     constructor Create;
     procedure Assign(Source: TPersistent); override;
published
     //: Height of the font in 1:20th of a point.
     property Height20: longword read GetHeight20 write SetHeight20;
     //: Font style. See @link(TXFontStyles).
     property FontStyle: TXFontStyles read GetFontStyle write SetFontStyle;
     //: Font escapment. See @link(TXSubSuperscript).
     property Escapment: TXSubSuperscript read GetSubSuperscript write SetSubSuperscript;
     //: Font underline. See @link(TXUnderline).
     property Underline: TXUnderline read GetUnderline write SetUnderline;
     //: Font color.
     property Color: TExcelColor read GetColor write SetColor;
     end;

type
//: Cell border style for conditional formats.
    TCondFmtBorder = class(TPersistent)
private
     FCFBorder: TCFBorder;
     // Left,Top,Right,Bottom
     FAssigned: array[0..3] of boolean;

     function  GetBottomColor: TExcelColor;
     function  GetBottomStyle: TCellBorderStyle;
     function  GetLeftColor: TExcelColor;
     function  GetLeftStyle: TCellBorderStyle;
     function  GetRightColor: TExcelColor;
     function  GetRightStyle: TCellBorderStyle;
     function  GetTopColor: TExcelColor;
     function  GetTopStyle: TCellBorderStyle;
     procedure SetBottomColor(const Value: TExcelColor);
     procedure SetBottomStyle(const Value: TCellBorderStyle);
     procedure SetLeftColor(const Value: TExcelColor);
     procedure SetLeftStyle(const Value: TCellBorderStyle);
     procedure SetRightColor(const Value: TExcelColor);
     procedure SetRightStyle(const Value: TCellBorderStyle);
     procedure SetTopColor(const Value: TExcelColor);
     procedure SetTopStyle(const Value: TCellBorderStyle);
     procedure SetRec(CFBorder: PCFBorder; Flags: longword);
     function  GetAssigned: boolean;
protected
     property Assigned: boolean read GetAssigned;
public
     constructor Create;
     procedure Assign(Source: TPersistent); override;
published
     //: Left border line style. See @link(TCellBorderStyle).
     property LeftStyle: TCellBorderStyle read GetLeftStyle write SetLeftStyle;
     //: Right border line style. See @link(TCellBorderStyle).
     property RightStyle: TCellBorderStyle read GetRightStyle write SetRightStyle;
     //: Top border line style. See @link(TCellBorderStyle).
     property TopStyle: TCellBorderStyle read GetTopStyle write SetTopStyle;
     //: Bottom border line style. See @link(TCellBorderStyle).
     property BottomStyle: TCellBorderStyle read GetBottomStyle write SetBottomStyle;
     //: Color for left border line.
     property LeftColor: TExcelColor read GetLeftColor write SetLeftColor;
     //: Color for right border line.
     property RightColor: TExcelColor read GetRightColor write SetRightColor;
     //: Color for top border line.
     property TopColor: TExcelColor read GetTopColor write SetTopColor;
     //: Color for bottom border line.
     property BottomColor: TExcelColor read GetBottomColor write SetBottomColor;
     end;

type
//: Fill pattern for conditional formats.
    TCondFmtPattern = class(TPersistent)
private
     FCFPattern: TCFPattern;
     // Patter, Fg color, Bg color
     FAssigned: array[0..2] of boolean;

     function  GetBackColor: TExcelColor;
     function  GetFillPattern: TExcelFillPattern;
     function  GetForeColor: TExcelColor;
     procedure SetBackColor(const Value: TExcelColor);
     procedure SetFillPattern(const Value: TExcelFillPattern);
     procedure SetForeColor(const Value: TExcelColor);
     procedure SetRec(CFPattern: PCFPattern; Flags: longword);
     function  GetAssigned: boolean;
protected
     property Assigned: boolean read GetAssigned;
public
     constructor Create;
     procedure Assign(Source: TPersistent); override;
published
     //: Fill pattern style. See @link(TExcelFillPattern).
     property FillPattern: TExcelFillPattern read GetFillPattern write SetFillPattern;
     //: Color for fill pattern foreground.
     property ForeColor: TExcelColor read GetForeColor write SetForeColor;
     //: Color for fill pattern background.
     property BackColor: TExcelColor read GetBackColor write SetBackColor;
     end;

type
//: Settings for one conditional format.
    TCondFmtData = class(TPersistent)
private
     FRecCF: PRecCF;
     FFormula1: TRecPTGS;
     FFormula2: TRecPTGS;
     FFmtFont: TCondFmtFont;
     FFmtBorder: TCondFmtBorder;
     FFmtPattern: TCondFmtPattern;
     FFormulaHandler: TFormulaHandler;

     function  GetCompareCell: boolean;
     function  GetCompOperator: TConditionOperator;
     function  GetFormula1: WideString;
     function  GetFormula2: WideString;
     procedure SetCompareCell(const Value: boolean);
     procedure SetCompOperator(const Value: TConditionOperator);
     procedure SetFormula1(const Value: WideString);
     procedure SetFormula2(const Value: WideString);
     procedure SetRec(RecCF: PRecCF);
protected
     function Assigned: boolean;
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);
public
     constructor Create(FmlaHandler: TFormulaHandler);
     procedure Assign(Source: TPersistent); override;

     destructor Destroy; override;
published
     //: CompareCell is True if the conditional format shall compare a cell
     //: value. When CompareCell is False, the formula in Formula1 is evaluated.
     property CompareCell: boolean read GetCompareCell write SetCompareCell;
     //: Condition operator. Only used when @link(CompareCell) is True.
     //: See also @link(TConditionOperator).
     property CompOperator: TConditionOperator read GetCompOperator write SetCompOperator;
     //: Formula for the first condition CompareCell is True, or the formula
     //: evaluated when CompareCell is False.
     property Formula1: WideString read GetFormula1 write SetFormula1;
     //: Second formula used when CompareCell is True, if needed.
     property Formula2: WideString read GetFormula2 write SetFormula2;
     //: Font to use for the cell when the condition is filled.
     property FmtFont: TCondFmtFont read FFmtFont write FFmtFont;
     //: Cell border to use for the cell when the condition is filled.
     property FmtBorder: TCondFmtBorder read FFmtBorder write FFmtBorder;
     //: Fill pattern to use for the cell when the condition is filled.
     property FmtPattern: TCondFmtPattern read FFmtPattern write FFmtPattern;
     end;

type
//: Conditional format for one or several cells given in Areas. A conditional
//: format can have up to three conditions. Each condition can have it's own
//: formatting settings for the cell. If more than one of the conditions are
//: met, the first condition is used to format the cell.
    TConditionalFormat = class(TCollectionItemMoveCopy)
private
     FCond1: TCondFmtData;
     FCond2: TCondFmtData;
     FCond3: TCondFmtData;
     FAreas: TCellAreas;
protected
     function Assigned: integer;
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);
     function  Intersect(Col1,Row1,Col2,Row2: integer): boolean; override;
     procedure Copy(Col1,Row1,Col2,Row2,DeltaCol,DeltaRow: integer); override;
     procedure Delete(Col1,Row1,Col2,Row2: integer); override;
     procedure Include(Col1,Row1,Col2,Row2: integer); override;
     procedure Move(DeltaCol,DeltaRow: integer); override;
     procedure Move(Col1,Row1,Col2,Row2,DeltaCol,DeltaRow: integer); override;
public
     constructor Create(Collection: TCollection); override;
     destructor Destroy; override;
     procedure Assign(Source: TPersistent); override;
published
     //: Condition number one.
     property Condition1: TCondFmtData read FCond1 write FCond1;
     //: Condition number two.
     property Condition2: TCondFmtData read FCond2 write FCond2;
     //: Condition number three.
     property Condition3: TCondFmtData read FCond3 write FCond3;
     //: Cells and areas that are formatted when the condition(s) are met.
     property Areas: TCellAreas read FAreas write FAreas;
     end;

type
//: List of conditional formats.
    TConditionalFormats = class(TCollectionMoveCopy)
private
     FOwner: TPersistent;
     FFormulaHandler: TFormulaHandler;

     function GetItems(Index: integer): TConditionalFormat;
protected
     function GetOwner: TPersistent; override;
public
     constructor Create(AOwner: TPersistent; FmlaHandler: TFormulaHandler);
     //: Add a new condition.
     function Add: TConditionalFormat;
     //: @exclude
     procedure LoadFromStream(Stream: TXLSStream; PBuf: PByteArray);
     //: @exclude
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);

     //: TConditionalFormat in the list. 
     property Items[Index: integer]: TConditionalFormat read GetItems; default;
     end;

implementation

{ TCondFmtFont }

procedure TCondFmtFont.Assign(Source: TPersistent);
begin
  Move(TCondFmtFont(Source).FCFFont,FCFFont,SizeOf(TCFFont));
  FAssigned := TCondFmtFont(Source).FAssigned;
end;

constructor TCondFmtFont.Create;
begin
  FAssigned := False;
  FillChar(FCFFont,SizeOf(TCFFont),#0);
  FCFFont.Height := $FFFFFFFF;
  FCFFont.Weight := 400;
  FCFFont.ColorIndex := $FFFFFFFF;
  FCFFont.ModifiedFlags := $0000009A;
  FCFFont.EscapementModified := $00000001;
  FCFFont.UnderlineModified := $00000001;
  FCFFont.Is0001 := $0001;
end;

function TCondFmtFont.GetColor: TExcelColor;
begin
  if FCFFont.ColorIndex = $FFFFFFFF then
    Result := xcAutomatic
  else
    Result := TExcelColor(FCFFont.ColorIndex);
end;

function TCondFmtFont.GetFontStyle: TXFontStyles;
begin
  Result := [];
  if (FCFFont.Options and $00000002) = $00000002 then
    Result := Result + [xfsItalic];
  if (FCFFont.Options and $00000080) = $00000002 then
    Result := Result + [xfsStrikeOut];
  if FCFFont.Weight >= 700 then
    Result := Result + [xfsBold];
end;

function TCondFmtFont.GetHeight20: longword;
begin
  Result := FCFFont.Height;
  if Result = $FFFFFFFF then
    Result := 0;
end;

function TCondFmtFont.GetSubSuperscript: TXSubSuperscript;
begin
  Result := TXSubSuperscript(FCFFont.Escapement);
end;

function TCondFmtFont.GetUnderline: TXUnderline;
begin
  case FCFFont.Underline of
    $00: Result := xulNone;
    $01: Result := xulSingle;
    $02: Result := xulDouble;
    $21: Result := xulSingleAccount;
    $22: Result := xulDoubleAccount;
    else
       Result := xulNone;
  end;
end;

procedure TCondFmtFont.SetColor(const Value: TExcelColor);