uxlsrangerecords.pas

来自「DELPHI界面增强控件,非常好,里面有显示GIF的图片控件,更美观的下拉框控件」· PAS 代码 · 共 678 行 · 第 1/2 页

unit UXlsRangeRecords;

interface
uses UXlsBaseRecords, UXlsBaseRecordLists, UXlsOtherRecords,
     XlsMessages, Classes, SysUtils, UFlxMessages, Math;

type
  TExcelRange= packed record
    R1, R2, C1, C2: word;
  end;
  PExcelRange= ^TExcelRange;

  TRangeValuesList= class(TList) //Items are TExcelRange
  private
    FOtherDataLen :word;
    procedure CopyIntersectRange(const R: PExcelRange; const NewFirstRow, NewLastRow, DestRow, aCount: integer; var MinR1, MaxR2: Word);
    function NextInRange(const Range: TXlsCellRange; const k: integer): integer;
  protected
      procedure Notify(Ptr: Pointer; Action: TListNotification); override;
  public
      constructor Create(const aOtherDataLen: word);

      procedure Load(const aRecord: TBaseRecord; const aPos: integer);

      //these methods are to split the record using Continue
      //excel doesn't like continued range records, so we don't use them
      procedure SaveToStreamC(const DataStream: TStream);
      function TotalSizeC: int64;
      function FirstRecordSizeC: integer;

      //these methods are to split the record repeating it
      procedure SaveToStreamR(const DataStream: TStream; const Line: integer);
      procedure SaveRangeToStreamR(const DataStream: TStream; const Line: integer; const aCount: integer; const Range: TXlsCellRange);
      function TotalSizeR(const aCount: integer): int64;
      function RepeatCountR(const aCount: integer): integer;
      function RecordSizeR(const Line: integer; const aCount:integer): integer;
      function CountRangeRecords(const Range: TXlsCellRange): integer;

      procedure CopyFrom( const RVL: TRangeValuesList);

      procedure ArrangeInsert(const aPos, aCount:integer);

     //Formats are copied if the range intersects with the original. (Merged cells need all the range to be inside the original)
      procedure CopyRowsInclusive(const FirstRow, LastRow, DestRow, aCount: integer; var MinR1, MaxR2: Word);
      procedure CopyRowsExclusive(const FirstRow, LastRow, DestRow, aCount: integer);
      procedure DeleteRows(const aRow, aCount: integer; const Allow1Cell: boolean);
      procedure PreAddNewRange(var R1,C1,R2,C2: integer);
      procedure AddNewRange(const FirstRow, FirstCol, LastRow, LastCol: integer);
  end;

  TRangeEntry = class
  private
  protected
    RangeValuesList: TRangeValuesList;
    function DoCopyTo: TRangeEntry; virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    function CopyTo: TRangeEntry;

    procedure LoadFromStream( const DataStream: TStream; const First: TRangeRecord);virtual;abstract;
    procedure SaveToStream(const DataStream: TStream);virtual;abstract;
    procedure SaveRangeToStream(const DataStream: TStream; const CellRange: TXlsCellRange);virtual;abstract;
    function TotalSize: int64;virtual; abstract;
    function TotalRangeSize(const CellRange: TXlsCellRange): int64;virtual; abstract;

    procedure ArrangeInsert(const aPos, aCount:integer; const SheetInfo: TSheetInfo);virtual;
    procedure InsertAndCopyRows(const FirstRow, LastRow, DestRow, aCount: integer; const SheetInfo: TSheetInfo); virtual;
    procedure DeleteRows(const aRow, aCount: word; const SheetInfo: TSheetInfo);virtual;
  end;

  //Merged cells can't be continued. We have to write independent records.
  TMergedCells = class (TRangeEntry)
  public
    constructor Create; override;

    procedure Clear;
    procedure LoadFromStream( const DataStream: TStream; const First: TRangeRecord); override;
    procedure SaveToStream(const DataStream: TStream); override;
    procedure SaveRangeToStream(const DataStream: TStream; const CellRange: TXlsCellRange);override;
    function TotalSize: int64; override;
    function TotalRangeSize(const CellRange: TXlsCellRange): int64;override;

    procedure InsertAndCopyRows(const FirstRow, LastRow, DestRow, aCount: integer; const SheetInfo: TSheetInfo); override;
    procedure DeleteRows(const aRow, aCount: word; const SheetInfo: TSheetInfo);override;

    function CheckCell(const aRow, aCol: integer; var CellBounds: TXlsCellRange): boolean;

    procedure PreMerge(var R1,C1,R2,C2: integer);
    procedure MergeCells(const FirstRow, FirstCol, LastRow, LastCol: integer);
  end;

  ClassOfTRangeEntry = class of TRangeEntry;

implementation

{ TRangeValuesList }

procedure TRangeValuesList.CopyFrom( const RVL: TRangeValuesList);
var
  i: integer;
  R: PExcelRange;
begin
  for i:=0 to RVL.Count-1 do
  begin
    New(R);
    try
      R^:=PExcelRange(RVL[i])^;
      Add(R);
    except
      FreeAndNil(R);
      raise;
    end; //except
  end;
end;

constructor TRangeValuesList.Create(const aOtherDataLen: word);
begin
  inherited Create;
  FOtherDataLen:= aOtherDataLen;
end;

function TRangeValuesList.FirstRecordSizeC: integer;
const
  Rl = SizeOf(TExcelRange);
var
  FirstRecCount, aCount: integer;
begin
  FirstRecCount := ((MaxRecordDataSize-2-FOtherDataLen) div Rl);
  if FirstRecCount<Count then aCount:= FirstRecCount else aCount:=Count;
  Result :=  2+ FOtherDataLen                          //Base data
            + Rl*aCount;                               // Registers

end;

procedure TRangeValuesList.ArrangeInsert(const aPos, aCount: integer);
var
  i:integer;
begin
  for i:=Count -1 downto 0 do
  begin
    if PExcelRange(Items[i]).R1>= aPos then IncMaxMin( PExcelRange(Items[i]).R1, aCount, Max_Rows, aPos);
    if PExcelRange(Items[i]).R2>= aPos then IncMaxMin( PExcelRange(Items[i]).R2, aCount, Max_Rows, PExcelRange(Items[i]).R1);
  end;
end;

procedure TRangeValuesList.CopyIntersectRange(const R: PExcelRange; const NewFirstRow, NewLastRow, DestRow, aCount: integer; var MinR1, MaxR2: Word);
var
  NewRange: PExcelRange;
  k, Lc: integer;
begin
  Lc:=(NewLastRow-NewFirstRow+1)* aCount;

  if (R.R1<=NewFirstRow) and (R.R2>=NewLastRow) then // Just copy one big range
  begin
    New(NewRange);
    try
      NewRange^:=R^;
      NewRange.R1:=DestRow;
      NewRange.R2:=DestRow+Lc-1;
      Add(NewRange);
      if NewRange.R1< MinR1 then MinR1:=NewRange.R1;
      if NewRange.R2> MaxR2 then MaxR2:=NewRange.R2;
    except
      Dispose(NewRange);
      raise;
    end; //Except
  end else // We have to copy one small range for each aCount
  begin
    for k:=0 to aCount -1 do
    begin
      New(NewRange);
      try
        NewRange^:=R^;
        NewRange.R1:=DestRow+(NewLastRow-NewFirstRow+1)*k;
        if R.R1>NewFirstRow then inc(NewRange.R1, R.R1-NewFirstRow);
        NewRange.R2:=DestRow+(NewLastRow-NewFirstRow+1)*(k+1)-1;
        if R.R2<NewLastRow then dec(NewRange.R2, NewLastRow-R.R2);

        Add(NewRange);
        if NewRange.R1< MinR1 then MinR1:=NewRange.R1;
        if NewRange.R2> MaxR2 then MaxR2:=NewRange.R2;
      except
        Dispose(NewRange);
        raise;
      end; //Except
    end;
  end;
end;

procedure TRangeValuesList.CopyRowsInclusive(const FirstRow, LastRow,
  DestRow, aCount: integer; var MinR1, MaxR2: word);
var
  i, Lc:integer;
  R: PExcelRange;
  NewFirstRow, NewLastRow: integer;
begin
  Lc:=(LastRow-FirstRow+1)* aCount;

  if FirstRow<DestRow then NewFirstRow:=FirstRow else NewFirstRow:=FirstRow+ Lc;
  if LastRow<DestRow then NewLastRow:=LastRow else NewLastRow:=LastRow+Lc;

  for i:=0 to Count-1 do
  begin
    R:=PExcelRange(Items[i]);
    if (R.R1<= NewLastRow) and
       (R.R2>= NewFirstRow) then
    begin
      //First Case, Block copied is above the original

      if (FirstRow>=DestRow) then
        if (R.R1<DestRow + Lc) then //nothing, range is automatically expanded
        else if (R.R1=DestRow + Lc) and( R.R2 >=NewLastRow) then //expand the range to include inserted rows
        begin
          Dec(R.R1, Lc);
          if R.R1< MinR1 then MinR1:=R.R1;
        end
        else CopyIntersectRange(R, NewFirstRow, NewLastRow, DestRow, aCount, MinR1, MaxR2) //We have to Copy the intersecting range, and clip the results

      //Second Case, Block copied is below the original

      else
        if (R.R2>DestRow-1) then //nothing, range is automatically expanded
        else if (R.R2=DestRow -1) and (R.R1<=NewFirstRow) then //expand the range to include inserted rows
        begin
          Inc(R.R2, Lc);
          if R.R2> MaxR2 then MaxR2:=R.R2;
        end
        else CopyIntersectRange(R, NewFirstRow, NewLastRow, DestRow, aCount, MinR1, MaxR2); //We have to Copy the intersecting range, and clip the results

    end;
  end;
end;

procedure TRangeValuesList.CopyRowsExclusive(const FirstRow,
  LastRow, DestRow, aCount: integer);
var
  i, k, Lc:integer;
  R, NewRange: PExcelRange;
  NewFirstRow, NewLastRow: integer;
begin
  Lc:=(LastRow-FirstRow+1)* aCount;

  if FirstRow<DestRow then NewFirstRow:=FirstRow else NewFirstRow:=FirstRow+ Lc;
  if LastRow<DestRow then NewLastRow:=LastRow else NewLastRow:=LastRow+Lc;

  for i:=0 to Count-1 do
  begin
    R:=PExcelRange(Items[i]);
    if (R.R1>= NewFirstRow) and
       (R.R2<= NewLastRow) then

      for k:=0 to aCount-1 do
      begin
        New(NewRange);
        try
          NewRange^:=R^;
          if (FirstRow>=DestRow) then
          begin
            IncMax(NewRange.R1, DestRow - FirstRow -(LastRow-FirstRow+1)*(k+1), Max_Rows);
            IncMax(NewRange.R2, DestRow - FirstRow -(LastRow-FirstRow+1)*(k+1), Max_Rows);
          end else
          begin
            IncMax(NewRange.R1, DestRow - FirstRow +(LastRow-FirstRow+1)*k, Max_Rows);
            IncMax(NewRange.R2, DestRow - FirstRow +(LastRow-FirstRow+1)*k, Max_Rows);
          end;
          add(NewRange);
        except
          Dispose(NewRange);
          raise;
        end; //Except
      end;
  end;
end;

procedure TRangeValuesList.DeleteRows(const aRow, aCount: integer; const Allow1Cell: boolean);
var
  i:integer;
  R:PExcelRange;
begin
  for i:=Count-1 downto 0 do
  begin
    R:=PExcelRange(Items[i]);
    if (R.R1>= aRow) and
      ((R.R2< aRow+aCount) or (not Allow1Cell and (R.R2=aRow+aCount) and (R.C1=R.C2))) then
        Delete(i);
  end;
end;

type
  //Just to avoid including windows.pas on d5
  TRect1 = packed record
    Left, Top, Right, Bottom: Integer;
  end;

procedure TRangeValuesList.PreAddNewRange(var R1,C1,R2,C2: integer);
var
  i: integer;
  OutRect: TRect1;
  R: PExcelRange;
begin
  //Check ranges are valid
  if (R1<0) or (R2<R1) or (R2>Max_Rows) or
     (C1<0) or (C2<C1) or (C2>Max_Columns) then exit;

  if (R1=R2)and(C1=C2) then exit;

  for i:=Count-1 downto 0 do
  begin
    R:=PExcelRange(Items[i]);
    OutRect.Left:=Max(R.C1, C1);
    OutRect.Top:=Max(R.R1, R1);
    OutRect.Right:=Min(R.C2, C2);
    OutRect.Bottom:=Min(R.R2, R2);
    if (OutRect.Left<=OutRect.Right)and(OutRect.Top<=OutRect.Bottom) then //found
    begin
      R1:=Min(R.R1, R1);
      R2:=Max(R.R2, R2);
      C1:=Min(R.C1, C1);
      C2:=Max(R.C2, C2);
      Delete(i);
    end;
  end;

end;

//We always have to call PreAddNewRange to verify it doesn't exist
procedure TRangeValuesList.AddNewRange(const FirstRow, FirstCol, LastRow, LastCol: integer);
var
  NewRange: PExcelRange;
begin
  //Check ranges are valid
  if (FirstRow<0) or (LastRow<FirstRow) or (LastRow>Max_Rows) or
     (FirstCol<0) or (LastCol<FirstCol) or (LastCol>Max_Columns) then exit;

  if (FirstRow=LastRow)and(FirstCol=LastCol) then exit;

  New(NewRange);