cellareas2.pas

一个经典的读写Excel的控件

unit CellAreas2;

{
********************************************************************************
******* 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.                                                     **
********************************************************************************
}

interface

uses Classes, SysUtils, Math, BIFFRECSII2, XLSUtils2;

type
//: Represents an area of cells.
    TCellArea = class(TCollectionItem)
private
     FCol1,FRow1,FCol2,FRow2: word;

     function  GetAsRecArea: TRecCellArea;
     procedure SetAsRecArea(const Value: TRecCellArea);
public
     procedure Normalize;
     procedure Assign(Source: TPersistent); override;
     procedure SetSize(C1,R1,C2,R2: word);

     property AsRecArea: TRecCellArea read GetAsRecArea write SetAsRecArea;
published
     //: First column in the area.
     property Col1: word read FCol1 write FCol1;
     //: First row in the area.
     property Row1: word read FRow1 write FRow1;
     //: Last column in the area.
     property Col2: word read FCol2 write FCol2;
     //: Last row in the area.
     property Row2: word read FRow2 write FRow2;
     end;

type
//: Base class for objects that manipulates cell areas.
    TCellAreas = class(TCollection)
private
     function GetItems(Index: integer): TCellArea;
protected
     FOwner: TPersistent;

     function  GetOwner: TPersistent; override;
     function  Combine(C1,R1,C2,R2: word): boolean;
     function  IntersectArea(Source1,Source2: TRecCellArea; var Dest: TRecCellArea): boolean;
     function  Split(Index: integer; Area: TRecCellArea): boolean;
//     procedure Added(var Item: TCollectionItem); override; ???
public
     constructor Create(AOwner: TPersistent);
     //: Add a new cell area.
     function  Add: TCellArea; overload;
     //: @exclude
     function  Add(RecArea: PRecCellArea): TCellArea; overload;
     //:# Add a new cell area.
     //: C1 = Left column. R1 = Top row. C2 = Right column. R2 = Bottom row.
     function  Add(C1,R1,C2,R2: word): TCellArea; overload;
     //:# Returns the smallest area that all areas in the list fits in.
     function  TotExtent: TRecCellArea;
     //:# Normalizes (i.e. checks that C1 < C2 and R1 < R2).
     procedure NormalizeAll;
     //:# Checks if an area intersects any of the areas.
     //: Returns True if the area given by Col1,Row1,Col2,Row2 intersects any
     //: of the areas in the list.
     function  AreaInAreas(Col1,Row1,Col2,Row2: word): boolean;
     //:# Check if a cell is in any of the areas.
     //: Returns the index of the area that the cell address given by Col and
     //: Row is within. If no match is found, -1 is returned.
     function  CellInAreas(Col,Row: word): integer;
     //:# Copies cell areas.
     //: Copies the cell areas that intersects the area given by Col1,Row1,
     //: Col2,Row2. The areas are copied DeltaCol and DeltaRow offset from
     //: their current position. DeltaCol and DeltaRow can be negative for
     //: copying left/up.
     procedure Copy(Col1,Row1,Col2,Row2: word; DeltaCol,DeltaRow: integer);
     //:# Delete areas.
     //: Delete the areas that intersects the area given by Col1,Row1,Col2,Row2.
     procedure Delete(Col1,Row1,Col2,Row2: word); overload;
     //:# Includes areas.
     //: All areas that intersects the area given by Col1,Row1,Col2,Row2 are
     //: kept. All others are deleted.
     procedure Include(Col1,Row1,Col2,Row2: word);
     //:# Moves areas.
     //: Move all areas by the offset DeltaCol,DeltaRow. DeltaCol and DeltaRow
     //: can be negative for moving left/up.
     procedure Move(DeltaCol,DeltaRow: integer); overload;
     //:# Moves areas.
     //: Move all areas that intersects the area given by Col1,Row1,Col2,Row2,
     //: by the offset DeltaCol,DeltaRow. DeltaCol and DeltaRow can be negative
     //: for moving left/up.
     procedure Move(Col1,Row1,Col2,Row2: word; DeltaCol,DeltaRow: integer); overload;
     //:# The areas in the list.
     property Items[Index: integer]: TCellArea read GetItems; default;
     end;


implementation

{ TCellAreas }

function TCellAreas.Add: TCellArea;
begin
  Result := TCellArea(inherited Add);
end;

function TCellAreas.Add(RecArea: PRecCellArea): TCellArea;
begin
  Result := TCellArea(inherited Add);
  Result.FCol1 := RecArea.Col1;
  Result.FRow1 := RecArea.Row1;
  Result.FCol2 := RecArea.Col2;
  Result.FRow2 := RecArea.Row2;
end;

constructor TCellAreas.Create(AOwner: TPersistent);
begin
  inherited Create(TCellArea);
  FOwner := AOwner;
end;

procedure TCellAreas.Delete(Col1, Row1, Col2, Row2: word);
var
  i,Cnt: integer;
  SelectArea,NewArea: TRecCellArea;
begin
  SelectArea.Col1 := Col1;
  SelectArea.Row2 := Row2;
  SelectArea.Col2 := Col2;
  SelectArea.Row1 := Row1;
  i := 0;
  // Save Count as number of elements may increase;
  Cnt := Count;
  while i < Cnt do begin
    if IntersectArea(Items[i].AsRecArea,SelectArea,NewArea) then begin
      Split(i,SelectArea);
      Delete(i);
      Dec(Cnt);
    end
    else
      Inc(i);
  end;
end;

function TCellAreas.GetItems(Index: integer): TCellArea;
begin
  Result := TCellArea(inherited Items[Index]);
end;

function TCellAreas.GetOwner: TPersistent;
begin
  Result := FOwner;
end;

function TCellAreas.AreaInAreas(Col1, Row1, Col2, Row2: word): boolean;
var
  i: integer;
  SelectArea,NewArea: TRecCellArea;
begin
  SelectArea.Col1 := Col1;
  SelectArea.Row2 := Row2;
  SelectArea.Col2 := Col2;
  SelectArea.Row1 := Row1;
  for i := 0 to Count - 1 do begin
    if IntersectArea(Items[i].AsRecArea,SelectArea,NewArea) then begin
      Result := True;
      Exit;
    end;
  end;
  Result := False;
end;

procedure TCellAreas.Copy(Col1, Row1, Col2, Row2: word; DeltaCol,DeltaRow: integer);
var
  i,Cnt: integer;
  SelectArea,NewArea: TRecCellArea;

procedure DoCopy(C1,R1,C2,R2: integer);
begin
  Inc(C1,DeltaCol);
  Inc(R1,DeltaRow);
  Inc(C2,DeltaCol);
  Inc(R2,DeltaRow);
  if ClipAreaToSheet(C1,R1,C2,R2) and not Combine(C1,R1,C2,R2) then begin
    Delete(C1,R1,C2,R2);
    Add(C1,R1,C2,R2);
  end;
end;

begin
  SelectArea.Col1 := Col1;
  SelectArea.Row2 := Row2;
  SelectArea.Col2 := Col2;
  SelectArea.Row1 := Row1;
  Cnt := Count;
  i := 0;
  while i < Cnt do begin
    if IntersectArea(Items[i].AsRecArea,SelectArea,NewArea) then
      DoCopy(NewArea.Col1,NewArea.Row1,NewArea.Col2,NewArea.Row2);
    Inc(i);
  end;
end;

procedure TCellAreas.NormalizeAll;
var
  i: integer;
begin
  for i := 0 to Count - 1 do
    Items[i].Normalize;
end;

function TCellAreas.TotExtent: TRecCellArea;
var
  i: integer;
begin
  Result.Row1 := $FFFF;
  Result.Row2 := 0;
  Result.Col1 := $FFFF;
  Result.Col2 := 0;
  for i := 0 to Count - 1 do begin
    Result.Col1 := Min(Result.Col1,Items[i].FCol1);
    Result.Row1 := Min(Result.Row1,Items[i].FRow1);
    Result.Col2 := Max(Result.Col2,Items[i].FCol2);
    Result.Row2 := Max(Result.Row2,Items[i].FRow2);
  end;
end;

function TCellAreas.Add(C1, R1, C2, R2: word): TCellArea;
begin
  Result := Add;
  Result.FCol1 := C1;
  Result.FRow1 := R1;
  Result.FCol2 := C2;
  Result.FRow2 := R2;
end;


procedure TCellAreas.Move(DeltaCol, DeltaRow: integer);
var
  i,C1,R1,C2,R2: integer;
begin
  i := 0;
  while i < Count do begin
    C1 := Items[i].FCol1 + DeltaCol;
    R1 := Items[i].FRow1 + DeltaRow;
    C2 := Items[i].FCol2 + DeltaCol;
    R2 := Items[i].FRow2 + DeltaRow;
    if not ClipAreaToSheet(C1,R1,C2,R2) then
      Delete(i)
    else begin
      Items[i].SetSize(C1,R1,C2,R2);
      Inc(i);
    end;
  end;
end;

procedure TCellAreas.Move(Col1, Row1, Col2, Row2: word; DeltaCol, DeltaRow: integer);
var
  i,Cnt: integer;
  SelectArea,NewArea: TRecCellArea;

procedure DoMove(C1,R1,C2,R2: integer);
begin
  Delete(i);
  Dec(Cnt);
  Inc(C1,DeltaCol);
  Inc(R1,DeltaRow);
  Inc(C2,DeltaCol);
  Inc(R2,DeltaRow);
  if ClipAreaToSheet(C1,R1,C2,R2) and not Combine(C1,R1,C2,R2) then begin
    Delete(C1,R1,C2,R2);
    Add(C1,R1,C2,R2);
  end;
end;

begin
  SelectArea.Col1 := Col1;
  SelectArea.Row2 := Row2;
  SelectArea.Col2 := Col2;
  SelectArea.Row1 := Row1;
  i := 0;
  // Save Count as number of elements may increase;
  Cnt := Count;
  while i < Cnt do begin
    if IntersectArea(Items[i].AsRecArea,SelectArea,NewArea) then begin
      Split(i,SelectArea);
      DoMove(NewArea.Col1,NewArea.Row1,NewArea.Col2,NewArea.Row2);
    end;
    Inc(i);
  end;
end;

// TODO: Will not handle the case where the new area fills the space between
// two existing areas. If included, check dependent functions, as this will
// require that one area is deleted. 
function TCellAreas.Combine(C1, R1, C2, R2: word): boolean;
var
  i: integer;
begin
  Result := True;
  for i := 0 to Count - 1 do begin
    with Items[i] do begin
      // Entirly inside the area.
      if (C1 >= FCol1) and (R1 >= FRow1) and (C2 <= FCol2) and (R2 <= FRow2) then
        Exit;
      if (FCol1 = C1) and (FCol2 = C2) then begin
        if (R2 >= (FRow1 - 1)) and (R2 <= FRow2) then begin
          FRow1 := R1;
          Exit;
        end
        else if (R1 >= FRow1) and (R1 <= (FRow2 + 1)) then begin
          FRow2 := R2;
          Exit;
        end;
      end
      else if (FRow1 = R1) and (FRow2 = R2) then begin
        if (C2 >= (FCol1 - 1)) and (C2 <= FCol2) then begin
          FCol1 := C1;
          Exit;
        end
        else if (C1 >= FCol1) and (C1 <= (FCol2 + 1)) then begin
          FCol2 := C2;
          Exit;
        end;
      end;
    end;
  end;
  Result := False;
end;

function TCellAreas.IntersectArea(Source1,Source2: TRecCellArea; var Dest: TRecCellArea): boolean;
begin
  if Source1.Col1 > Source2.Col1 then Dest.Col1 := Source1.Col1 else Dest.Col1 := Source2.Col1;
  if Source1.Row1 > Source2.Row1 then Dest.Row1 := Source1.Row1 else Dest.Row1 := Source2.Row1;
  if Source1.Col2 < Source2.Col2 then Dest.Col2 := Source1.Col2 else Dest.Col2 := Source2.Col2;
  if Source1.Row2 < Source2.Row2 then Dest.Row2 := Source1.Row2 else Dest.Row2 := Source2.Row2;
  Result := (Dest.Row1 <= Dest.Row2) and (Dest.Col1 <= Dest.Col2);
end;

function TCellAreas.Split(Index: integer; Area: TRecCellArea): boolean;
var
  i,SplitCnt: integer;
  TmpR1,TmpR2: word;
  SplitAreas: array[0..3] of TRecCellArea;
begin
  SplitCnt := 0;
  TmpR1 := Items[Index].FRow1;
  TmpR2 := Items[Index].FRow2;

  if Area.Row1 > Items[Index].FRow1 then begin
    SplitAreas[SplitCnt].Col1 := Items[Index].FCol1;
    SplitAreas[SplitCnt].Row1 := Items[Index].FRow1;
    SplitAreas[SplitCnt].Col2 := Items[Index].FCol2;
    SplitAreas[SplitCnt].Row2 := Area.Row1 - 1;
    Inc(SplitCnt);
    TmpR1 := Area.Row1;
  end;


  if Area.Row2 < Items[Index].FRow2 then begin
    SplitAreas[SplitCnt].Col1 := Items[Index].FCol1;
    SplitAreas[SplitCnt].Row1 := Area.Row2 + 1;
    SplitAreas[SplitCnt].Col2 := Items[Index].FCol2;
    SplitAreas[SplitCnt].Row2 := Items[Index].FRow2;
    Inc(SplitCnt);
    TmpR2 := Area.Row2;
  end;

  if Area.Col1 > Items[Index].FCol1 then begin
    SplitAreas[SplitCnt].Col1 := Items[Index].Col1;
    SplitAreas[SplitCnt].Row1 := TmpR1;
    SplitAreas[SplitCnt].Col2 := Area.Col1 - 1;
    SplitAreas[SplitCnt].Row2 := TmpR2;
    Inc(SplitCnt);
  end;

  if Area.Col2 < Items[Index].FCol2 then begin
    SplitAreas[SplitCnt].Col1 := Area.Col2 + 1;
    SplitAreas[SplitCnt].Row1 := TmpR1;
    SplitAreas[SplitCnt].Col2 := Items[Index].Col2;
    SplitAreas[SplitCnt].Row2 := TmpR2;
    Inc(SplitCnt);
  end;
  for i := 0 to SplitCnt - 1 do
    Add(@SplitAreas[i]);
  Result := SplitCnt > 0;
end;

procedure TCellAreas.Include(Col1, Row1, Col2, Row2: word);
var
  i,Cnt: integer;
  SelectArea,NewArea: TRecCellArea;
begin
  SelectArea.Col1 := Col1;
  SelectArea.Row2 := Row2;
  SelectArea.Col2 := Col2;
  SelectArea.Row1 := Row1;
  Cnt := Count;
  i := 0;
  while i < Cnt do begin
    if IntersectArea(Items[i].AsRecArea,SelectArea,NewArea) then begin
      Items[i].AsRecArea := NewArea;
      Inc(i);
    end
    else begin
      Delete(i);
      Dec(Cnt);
    end;
  end;
end;

function TCellAreas.CellInAreas(Col, Row: word): integer;
begin
  for Result := 0 to Count - 1 do begin
    if (Col >= Items[Result].FCol1) and (Col <= Items[Result].FCol2) and (Row >= Items[Result].FRow1) and (Row <= Items[Result].FRow2) then
      Exit;
  end;
  Result := -1;
end;

{ TCellArea }

procedure TCellArea.Assign(Source: TPersistent);
begin
  FRow1 := TCellArea(Source).FRow1;
  FRow2 := TCellArea(Source).FRow2;
  FCol1 := TCellArea(Source).FCol1;
  FCol2 := TCellArea(Source).FCol2;
end;

function TCellArea.GetAsRecArea: TRecCellArea;
begin
  Result.Col1 := FCol1;
  Result.Row1 := FRow1;
  Result.Col2 := FCol2;
  Result.Row2 := FRow2;
end;

procedure TCellArea.Normalize;

procedure Swap(var W1,W2: word);
var
  T: Word;
begin
  T := W1;
  W1 := W2;
  W2 := T;
end;

begin
  if FCol1 > FCol2 then
    Swap(FCol1,FCol2);
  if FRow1 > FRow2 then
    Swap(FRow1,FRow2);
end;

procedure TCellArea.SetAsRecArea(const Value: TRecCellArea);
begin
  FCol1 := Value.Col1;
  FRow1 := Value.Row1;
  FCol2 := Value.Col2;
  FRow2 := Value.Row2;
end;

procedure TCellArea.SetSize(C1, R1, C2, R2: word);
begin
  FCol1 := C1;
  FRow1 := R1;
  FCol2 := C2;
  FRow2 := R2;
end;

end.