columns2.pas

一个经典的读写Excel的控件

unit Columns2;

{
********************************************************************************
******* 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, Contnrs, BIFFRECSII2, XLSRWIIResourceStrings2,
     CellFormats2, FormattedObj2, XLSStream2, Graphics, Windows, Math;

//: Default width of a column in units of 1/256s of a character width.
const DEFAULT_COLWIDTH = 2500;

type
//:# TXLSColumn represents a column in a worksheet.
//: In order to format all cells in a column, format the column and not the
//: individual cells, as this will save space and execute faster.
    TXLSColumn = class(TFormattedObjectNotify)
private
     FIndex: byte;
     FWidth: integer;
     FHidden: boolean;
     FOutlineLevel: byte;
     FCollapsedOutline: boolean;
     FUnknownOptionsFlag: boolean;

     procedure SetWidth(Value: integer);
     procedure SetOutlineLevel(Value: byte);
     function  GetCharWidth: double;
     procedure SetCharWidth(const Value: double);
     function  GetPixelWidth: integer;
     procedure SetPixelWidth(const Value: integer);
protected
     function  GetIndex: integer; override;
     function  IsDefault: boolean;
     function  Equal(XCol: TXLSColumn): boolean;
public
     constructor Create(Index: byte; Formats: TCellFormats; FormatIndex: word; ChangeEvent: TFormatEvent);
     //: Assign another column to this column.
     procedure Assign(Source: TXLSColumn);

     //: Set to true if outline is collapsed.
     property CollapsedOutline: boolean read FCollapsedOutline write FCollapsedOutline;
     //: Set to true if the column is hidden
     property Hidden: boolean read FHidden write FHidden;
     //: Sets or returns the outline level. The value can be in the range
     //: 0-16, where zero is no outline.
     property OutlineLevel: byte read FOutlineLevel write SetOutlineLevel;
     //: The width of the column in units of 1/256s of a character width.
     property Width: integer read FWidth write SetWidth;
     //: The width of the column in characters.
     property CharWidth: double read GetCharWidth write SetCharWidth;
     //: The width of the column in pixels.
     property PixelWidth: integer read GetPixelWidth write SetPixelWidth;
     end;

type
//: Holds a list of all columns. There can be max 256 columns in a worksheet.
//: Only columns that are changed can be read trough the Items property, i.e
//: default columns are not stored.
//: In order to set data for a column, and there is no TXLSColumn assigned to
//: it, use InsertColumn to create columns.
    TXLSColumns = class(TObject)
private
     FCols: array[0..MAXCOL] of TXLSColumn;
     FFormats: TCellFormats;
     FFormatChangeEvent: TFormatEvent;

     function  GeTXLSColumn(Col: integer): TXLSColumn;
protected
     function  ValidColumns(Col1,Col2: integer): boolean;
public
     constructor Create(Formats: TCellFormats);
     destructor Destroy; override;
     //: Clears all columns.
     procedure Clear;
     //: @exclude
     procedure SetRecCOLINFO(Rec: PRecCOLINFO);
     //: Returns the witdth for column Col. If there is no column at Col, the
     //: default column width is returned.
     function  GetColWidth(Col: integer): integer;
     //: Returns the column width in pixels for column Col. If there is no
     //: column at Col, the default column width is returned. In order to
     //: get the correct value, Canvas must have the default workbook font
     //: assigned to it.
     function  GetColWidthPixels(Canvas: TCanvas; Col: integer): integer;
     //: Sets the width (in units of 1/256s of a character) for colmns Col1 to
     //: Col2.
     procedure SetColWidth(Col1,Col2: integer; Value: integer);
     //: Sets the width in characters for colmns Col1 to Col2.
     procedure SetColWidthChar(Col1,Col2: integer; Value: double);
     //: Delets all columns between Col1 and Col2. Columns to the right of
     //: Col2 will be shifted left.
     procedure DeleteColumns(Col1,Col2: integer);
     //: Delets all columns between Col1 and Col2.
     procedure ClearColumns(Col1,Col2: integer);
     //: Copies columns between Col1 to Col2 to DestCol. Only the column width
     //: and other column data is copied. Cells will remain unchanged. In order
     //: to copy cell values as well, see @link(TXLSReadWriteII2.CopyColumns).
     procedure CopyColumns(Col1,Col2,DestCol: integer);
     //: Moves columns between Col1 to Col2 to DestCol. Only the column width
     //: and other column data is moved. Cells will remain unchanged. In order
     //: to move cell values as well, see @link(TXLSReadWriteII2.MoveColumns).
     procedure MoveColumns(Col1,Col2,DestCol: integer);
     //: Inserts ColCount columns at Col. Existing columns will be shifted
     //: left.
     procedure InsertColumns(Col,ColCount: integer);
     //: @exclude
     procedure SaveToStream(Stream: TXLSStream; PBuf: PByteArray);
     //: @exclude
     procedure CopyList(List: TList; Col1,Col2: integer);
     //: @exclude
     procedure InsertList(List: TList; DestCol,ColCount: integer);
     //:# The columns in the list.
     //: Col is the column number. If there is no TXLSColumn at Col, Nil will
     //: be returned.
     property  Items[Col: integer]: TXLSColumn read GeTXLSColumn; default;
     //: @exclude
     property  OnFormatChange: TFormatEvent read FFormatChangeEvent write FFormatChangeEvent;
     end;

implementation

{ TXLSColumn }

procedure TXLSColumn.Assign(Source: TXLSColumn);
begin
  AssignFormat(Source.FFormat);
  FWidth := Source.FWidth;
  FHidden := Source.FHidden;
  FOutlineLevel := Source.FOutlineLevel;
  FCollapsedOutline := Source.FCollapsedOutline;
  FUnknownOptionsFlag := Source.FUnknownOptionsFlag;
end;

constructor TXLSColumn.Create(Index: byte; Formats: TCellFormats; FormatIndex: word; ChangeEvent: TFormatEvent);
begin
  inherited Create(Formats,FormatIndex);
  FIndex := Index;
  FWidth := DEFAULT_COLWIDTH;
  FChangeEvent := ChangeEvent;
end;

function TXLSColumn.Equal(XCol: TXLSColumn): boolean;
begin
  Result := (XCol.FWidth = FWidth) and
            (XCol.FHidden = FHidden) and
            (XCol.FOutlineLevel = FOutlineLevel) and
            (XCol.FCollapsedOutline = FCollapsedOutline) and
            (XCol.FormatIndex = FormatIndex);
end;

function TXLSColumn.GetCharWidth: double;
begin
  Result := FWidth / 256;
end;

function TXLSColumn.GetIndex: integer;
begin
  Result := FIndex;
end;

function TXLSColumn.GetPixelWidth: integer;
var
  Canvas: TCanvas;
  F: TFont;
begin
  Canvas := TCanvas.Create;
  Canvas.Handle := GetDC(0);
  try
    F := TFont.Create;
    try
      FFormats.Fonts[0].CopyToTFont(F);
      Canvas.Font.Assign(F);
      Result := Round((FWidth / 256) * Canvas.TextWidth('8'));
    finally
      F.Free;
    end;
  finally
    Canvas.Free;
  end;
end;

function TXLSColumn.IsDefault: boolean;
begin
  Result := (FWidth = DEFAULT_COLWIDTH) and
            not FHidden and
            (FOutlineLevel = 0) and
            not FCollapsedOutline and
            not IsFormatted;
end;

procedure TXLSColumn.SetCharWidth(const Value: double);
begin
  SetWidth(Round(Value * 256));
end;

procedure TXLSColumn.SetOutlineLevel(Value: byte);
begin
  if Value > $10 then
    raise Exception.Create(ersInvalidValue);
  FOutlineLevel := Value;
end;

procedure TXLSColumn.SetPixelWidth(const Value: integer);
var
  Canvas: TCanvas;
  F: TFont;
begin
  Canvas := TCanvas.Create;
  Canvas.Handle := GetDC(0);
  try
    F := TFont.Create;
    try
      FFormats.Fonts[0].CopyToTFont(F);
      Canvas.Font.Assign(F);
      FWidth := (Value * 256) div Canvas.TextWidth('8');
    finally
      F.Free;
    end;
  finally
    Canvas.Free;
  end;
end;