rows2.pas

一个经典的读写Excel的控件

unit Rows2;

{
********************************************************************************
******* 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, XLSUtils2, BIFFRecsII2, CellFormats2,
     FormattedObj2;

const DEFAULT_ROWHEIGHT = 255;

type
//:# TXLSRow represents a row in a worksheet.
//: In order to format all cells in a row, format the row and not the
//: individual cells, as this will save space and execute faster.
    TXLSRow = class(TFormattedObjectNotify)
private
     FRow: word;
     FCol1,FCol2: word;
     FHeight: word;
     FOptions: word;

     function  GetHidden: boolean;
     procedure SetHidden(const Value: boolean);
protected
     function  GetIndex: integer; override;
     function  IsDefault: boolean;
public
     constructor Create(Formats: TCellFormats; FormatIndex: word; ChangeEvent: TFormatEvent);
     //:# Assign another row to this row.
     procedure Assign(Source: TXLSRow);

     //: The heigh of the row in units of 1/20 of a character point.
     property Height: word read FHeight write FHeight;
     //:# Set to true if the row is hidden
     property Hidden: boolean read GetHidden write SetHidden;
     //: @exclude
     property Options: word read FOptions write FOptions;
     end;

type
//: Holds a list of all rows. There can be max 65536 rows in a worksheet.
//: Only rows that are changed can be read trough the Items property, i.e
//: default rows are not stored.
//: In order to set data for a row, and there is no TXLSRow assigned to
//: it, use the AddIfNone method to create rows.
    TXLSRows = class(TObjectList)
private
     FFormats: TCellFormats;
     FFormatChangeEvent: TFormatEvent;

     function  GetItemByIndex(Index: integer): TXLSRow;
     procedure ValidRows(Row1,Row2: integer);
     function  FindClosestIndex(Row: integer): integer;
     function  GetFirstLastIndex(Row1,Row2: integer; var Index1,Index2: integer): boolean;
     function  FindIndex(Row: integer): integer;
     procedure SetItemByIndex(Index: integer; const Value: TXLSRow);

     property  ItemByIndex[Index: integer]: TXLSRow read GetItemByIndex write SetItemByIndex;
     function  GetItem(Row: integer): TXLSRow;
public
     constructor Create(Formats: TCellFormats);
     procedure SetRecROW(ARow: PRecROW; FormatIndex: word);
     procedure GetRecROW(Index: integer; ARow: PRecROW);
     function  AddIfNone(Row: integer): TXLSRow;
     //: Delets all rows between Row1 and Row2. Rows to the bottom of
     //: Row2 will be shifted up.
     procedure DeleteRows(Row1,Row2: integer);
     //: Delets all rows between Row1 and Row2.
     procedure ClearRows(Row1,Row2: integer);
     //: Copies rows between Row1 to Row2 to DestRow. Only the row height
     //: and other row data is copied. Cells will remain unchanged. In order
     //: to copy cell values as well, see @link(TXLSReadWriteII2.CopyRows).
     procedure CopyRows(Row1,Row2,DestRow: integer);
     //: Moves rows between Row1 to Row2 to DestRow. Only the row height
     //: and other row data is moved. Cells will remain unchanged. In order
     //: to move cell values as well, see @link(TXLSReadWriteII2.MoveRows).
     procedure MoveRows(Row1,Row2,DestRow: integer);
     //: Inserts RowCount rows at Row. Existing rows will be shifted
     //: left.
     procedure InsertRows(Row,RowCount: integer);
     //: Sets the height (in units of 1/256s of a character) for rows Row1 to
     //: Row2.
     procedure SetRowHeight(Row1,Row2,Height: integer);
     //: Returns the witdth for row Row. If there is no row at Row, the
     //: default row height is returned.
     function  GetRowHeight(Row: integer): integer;
     function  Find(Row: integer): TXLSRow;
     procedure Sort;
     procedure CopyList(List: TList; Row1,Row2: integer);
     procedure InsertList(List: TList; DestRow,RowCount: integer);
     //:# The rows in the list.
     //: Row is the row number. If there is no TXLSRow at Row, Nil will be
     //: returned.
     property  Items[Row: integer]: TXLSRow read GetItem; default;

     property  OnFormatChange: TFormatEvent read FFormatChangeEvent write FFormatChangeEvent;
     end;


implementation

{ TXLSRow }

procedure TXLSRow.Assign(Source: TXLSRow);
begin
  AssignFormat(Source.FFormat);
  FRow := Source.FRow;
  FCol1 := Source.FCol1;
  FCol2 := Source.FCol2;
  FHeight := Source.FHeight;
  FOptions := Source.FOptions;
end;

constructor TXLSRow.Create(Formats: TCellFormats; FormatIndex: word; ChangeEvent: TFormatEvent);
begin
  inherited Create(Formats,FormatIndex);
  FChangeEvent := ChangeEvent;
  if FormatIndex <> DEFAULT_FORMAT then
    FOptions := $0080;
end;

function TXLSRow.GetHidden: boolean;
begin
  Result := (FOptions and $0020) = $0020;
end;

function TXLSRow.GetIndex: integer;
begin
  Result := FRow;
end;

function TXLSRow.IsDefault: boolean;
begin
  Result := not IsFormatted and (FHeight = DEFAULT_ROWHEIGHT) and not GetHidden;
end;

procedure TXLSRow.SetHidden(const Value: boolean);
begin
  FOptions := FOptions or $0020;
end;

{ TXLSRows }

function TXLSRows.AddIfNone(Row: integer): TXLSRow;
begin
  Result := Find(Row);
  if Result = Nil then begin
    Result := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
    Result.FRow := Row;
    inherited Add(Result);
    Sort;
  end;
end;

procedure TXLSRows.ClearRows(Row1, Row2: integer);
var
  i,Start,Stop: integer;
begin
  ValidRows(Row1,Row2);
  if not GetFirstLastIndex(Row1,Row2,Start,Stop) then
    Exit;
  i := Start;
  while i <= Stop do begin
    if (ItemByIndex[i].FRow >= Row1) and (ItemByIndex[i].FRow <= Row2) then begin
      Delete(i);
      Dec(Stop);
    end
    else
      Inc(i);
  end;
end;

procedure TXLSRows.CopyList(List: TList; Row1, Row2: integer);
var
  i,j: integer;
begin
  ValidRows(Row1,Row2);
  if (Row1 = 0) and (Row2 = MAXROW) then begin
    for i := 0 to Count - 1 do
      List.Add(ItemByIndex[i]);
  end
  else begin
    for i := Row1 to Row2 do begin
      j := FindIndex(i);
      if j >= 0 then
        List.Add(ItemByIndex[i]);
    end;
  end;
end;

procedure TXLSRows.CopyRows(Row1, Row2, DestRow: integer);
var
  i,Cnt,Start,Stop: integer;
  XRow: TXLSRow;
begin
  if DestRow >= MAXROW then
    Exit;
  ValidRows(Row1,Row2);
  Cnt := (Row2 - Row1 + 1);
  ClearRows(DestRow,DestRow + Cnt);
  if not GetFirstLastIndex(Row1,Row2,Start,Stop) then
    Exit;
  i := Start;
  while i <= Stop do begin
    if (ItemByIndex[i].FRow >= Row1) and (ItemByIndex[i].FRow <= Row2) then begin
      XRow := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
      XRow.Assign(ItemByIndex[i]);
      XRow.FRow := DestRow + (ItemByIndex[i].FRow - Row1);
      inherited Add(XRow);
    end;
    Inc(i);
  end;
  Sort;
end;

constructor TXLSRows.Create(Formats: TCellFormats);
begin
  inherited Create;
  FFormats := Formats;
end;

procedure TXLSRows.DeleteRows(Row1, Row2: integer);
var
  i,Start,Stop,Last: integer;
begin
  ValidRows(Row1,Row2);
  if not GetFirstLastIndex(Row1,Row2,Start,Stop) then
    Exit;
  Last := -1;
  i := Start;
  while i <= Stop do begin
    if (ItemByIndex[i].FRow >= Row1) and (ItemByIndex[i].FRow <= Row2) then begin
      Delete(i);
      Dec(Stop);
      Last := i;
    end
    else
      Inc(i);
  end;
  if Last > (Count - 1) then
    Exit;
  for i := Last to Count - 1 do
    ItemByIndex[i].FRow := ItemByIndex[i].FRow - (Row2 - Row1 + 1);
end;

function TXLSRows.Find(Row: integer): TXLSRow;
var
  i: integer;
begin
  i := FindIndex(Row);
  if i >= 0 then
    Result := ItemByIndex[i]
  else
    Result := Nil;
end;

function TXLSRows.FindClosestIndex(Row: integer): integer;
var
  First : Integer;
  Last  : Integer;
begin
  First := 0;
  Last := Count - 1;
  Result := -1;

  while First <= Last do begin
    Result := (First + Last) div 2;
    if ItemByIndex[Result].FRow = Row then
      Break;
    if ItemByIndex[Result].FRow > Row then
      Last := Result - 1
    else
      First := Result + 1;
  end;

  if (Result < 0) or (Result > (Count - 1)) then
    Exit
  else if (Result >= Count) and (ItemByIndex[Result].FRow > Row) then
    Inc(Result)
  else if ItemByIndex[Result].FRow < Row then
    Inc(Result);
end;

function TXLSRows.FindIndex(Row: integer): integer;
var
  i,lo,hi: integer;
begin
  if (Row < 0) or (Count <= 0) or (Row > MAXROW) then begin
    Result := -1;
    Exit;
  end;
  i := 0;
  lo := 0;
  hi := Count - 1;
  while lo <= hi do begin
    i := (lo + hi) div 2;
    if Row > ItemByIndex[i].FRow then
      lo := i + 1
    else if Row < ItemByIndex[i].FRow then
      hi := i - 1
    else
      Break;
  end;
  if Row = ItemByIndex[i].FRow then
    Result := i
  else
    Result := -1;
end;

function TXLSRows.GetFirstLastIndex(Row1, Row2: integer; var Index1, Index2: integer): boolean;
begin
  Result := False;
  Index1 := FindClosestIndex(Row1);
  if Index1 < 0 then
    Exit;
  if Index1 > 0 then
    Dec(Index1);
  Index2 := FindClosestIndex(Row2);
  if Index2 < (Count - 1) then
    Inc(Index2);
  Result := True;
end;

function TXLSRows.GetItem(Row: integer): TXLSRow;
begin
  Result := Find(Row);
end;

function TXLSRows.GetItemByIndex(Index: integer): TXLSRow;
begin
  Result := TXLSRow(inherited Items[Index]);
end;

procedure TXLSRows.GetRecROW(Index: integer; ARow: PRecROW);
begin
  ARow.Row := ItemByIndex[Index].FRow;
  ARow.Col1 := ItemByIndex[Index].FCol1;
  ARow.Col2 := ItemByIndex[Index].FCol2;
  ARow.Height := ItemByIndex[Index].FHeight;
  if ItemByIndex[Index].FormatIndex <> DEFAULT_FORMAT then
    ARow.Options := ItemByIndex[Index].FOptions or $0080
  else
    ARow.Options := ItemByIndex[Index].FOptions and not $0080;
  ARow.FormatIndex := ItemByIndex[Index].FormatIndex;
  ARow.Reserved1 := 0;
  ARow.Reserved2 := 0;
end;

function TXLSRows.GetRowHeight(Row: integer): integer;
var
  XRow: TXLSRow;
begin
  XRow := Find(Row);
  if XRow <> Nil then
    Result := XRow.FHeight
  else
    Result := DEFAULT_ROWHEIGHT;
end;

procedure TXLSRows.InsertList(List: TList; DestRow, RowCount: integer);
var
  i: integer;
  XRow: TXLSRow;
begin
  MoveRows(DestRow,DestRow + RowCount - 1,DestRow + RowCount);
  for i := 0 to List.Count - 1 do begin
    XRow := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
    XRow.Assign(TXLSRow(List[i]));
    Add(XRow);
  end;
end;

procedure TXLSRows.InsertRows(Row, RowCount: integer);
var
  i,Start: integer;
  XRow,SrcRow: TXLSRow;
begin
  if (Row < 0) or (Row > MAXROW) then
    raise Exception.Create('Invalid row');
  SrcRow := Find(Row - 1);

  Start := FindClosestIndex(Row);
  for i := Start to Count - 1 do
    ItemByIndex[i].FRow := ItemByIndex[i].FRow + RowCount;

  for i := 0 to RowCount - 1 do begin
    XRow := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
    if (SrcRow <> Nil) and not SrcRow.IsDefault then
      XRow.Assign(SrcRow);
    XRow.FRow := Row + i;
    inherited Add(XRow);
  end;
  Sort;
end;

procedure TXLSRows.MoveRows(Row1, Row2, DestRow: integer);
begin
  CopyRows(Row1,Row2,DestRow);
  ClearRows(Row1,Row2);
end;

procedure TXLSRows.SetItemByIndex(Index: integer; const Value: TXLSRow);
begin
  inherited Items[Index] := Value;
end;

procedure TXLSRows.SetRecROW(ARow: PRecROW; FormatIndex: word);
var
  R: TXLSRow;
begin
  if (ARow.Options and $0080) = $0080 then
    R := TXLSRow.Create(FFormats,ARow.FormatIndex,FFormatChangeEvent)
  else
    R := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
  R.FRow := ARow.Row;
  R.FCol1 := ARow.Col1;
  R.FCol2 := ARow.Col2;
  R.FHeight := ARow.Height;
  R.FOptions := ARow.Options;
  inherited Add(R);
end;

procedure TXLSRows.SetRowHeight(Row1, Row2, Height: integer);
var
  i,j: integer;
  XRow: TXLSRow;
begin
  ValidRows(Row1,Row2);
  for i := Row1 to Row2 do begin
    j := FindIndex(i);
    if j >= 0 then begin
      ItemByIndex[j].FHeight := Height;
      if Height <> DEFAULT_ROWHEIGHT then
        ItemByIndex[j].FOptions := ItemByIndex[j].FOptions or $0040
      else
        ItemByIndex[j].FOptions := ItemByIndex[j].FOptions and not $0040;
      if ItemByIndex[j].IsDefault then
        Delete(j);
    end
    else if Height <> DEFAULT_ROWHEIGHT then begin
      XRow := TXLSRow.Create(FFormats,DEFAULT_FORMAT,FFormatChangeEvent);
      XRow.FRow := i;
      XRow.FHeight := Height;
      XRow.FOptions := XRow.FOptions or $0040;
      inherited Add(XRow);
    end;
  end;
  Sort;
end;

procedure TXLSRows.Sort;

procedure QSort(L, R: Integer);
var
  I, J, Row: Integer;
begin
  repeat
    i := L;
    j := R;
    Row := ItemByIndex[(L + R) shr 1].FRow;
    repeat
      while ItemByIndex[i].FRow < Row do Inc(i);
      while ItemByIndex[j].FRow > Row do Dec(j);
      if I <= J then begin
        Exchange(i,j);
        Inc(i);
        Dec(j);
      end;
    until I > J;
    if L < j then QSort(L, j);
    L := i;
  until i >= R;
end;


begin
  if Count > 0 then
    QSort(0,Count - 1);
end;

procedure TXLSRows.ValidRows(Row1, Row2: integer);
begin
  if (Row1 < 0) or (Row1 > MAXROW) or (Row2 < 0) or (Row2 > MAXROW) or (Row2 < Row1) then
    raise Exception.Create('Invalid rows');
end;

end.