pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

fpspreadsheet: Initial version of worksheet sorting. Add sorting parameters dialog to spready. Basic demonstration of sorting in spready.

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3675 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-10-21 15:12:51 +00:00
parent 8891b0a90b
commit 68649b7275
7 changed files with 729 additions and 14 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
components/fpspreadsheet/examples/spready/mainform.lfm
View File

@ -10,7 +10,7 @@ object MainFrm: TMainFrm
OnActivate = FormActivate
OnCreate = FormCreate
ShowHint = True
LCLVersion = '1.2.6.0'
LCLVersion = '1.3'
object Panel1: TPanel
Left = 0
Height = 82
@ -927,6 +927,15 @@ object MainFrm: TMainFrm
FF007590C3FF2359BFFF0541BBFF1D55BFFF758FC1FFFFFFFF00
}
end
object MenuItem77: TMenuItem
Caption = '-'
end
object MenuItem79: TMenuItem
Action = AcSort
end
object MenuItem78: TMenuItem
Action = AcSortColAsc
end
end
object mnuFormat: TMenuItem
Caption = 'Format'
@ -3197,8 +3206,15 @@ object MainFrm: TMainFrm
Hint = 'Modify the global settings for number and date/time formatting'
OnExecute = AcFormatSettingsExecute
end
object Action1: TAction
Caption = 'Action1'
object AcSortColAsc: TAction
Caption = 'Sort column only (ascending)'
Hint = 'Sort selected column (ascending)'
OnExecute = AcSortColAscExecute
end
object AcSort: TAction
Caption = 'Sort...'
Hint = 'Sort selected range'
OnExecute = AcSortExecute
end
end
object FontDialog: TFontDialog

58
components/fpspreadsheet/examples/spready/mainform.pas
View File

@ -79,7 +79,8 @@ type
AcDeleteRow: TAction;
AcCSVParams: TAction;
AcFormatSettings: TAction;
Action1: TAction;
AcSortColAsc: TAction;
AcSort: TAction;
AcViewInspector: TAction;
AcWordwrap: TAction;
AcVAlignDefault: TAction;
@ -171,6 +172,9 @@ type
MenuItem74: TMenuItem;
MenuItem75: TMenuItem;
MenuItem76: TMenuItem;
MenuItem77: TMenuItem;
MenuItem78: TMenuItem;
MenuItem79: TMenuItem;
MnuCSVParams: TMenuItem;
MnuSettings: TMenuItem;
mnuInspector: TMenuItem;
@ -291,6 +295,8 @@ type
procedure AcSaveAsExecute(Sender: TObject);
procedure AcShowGridlinesExecute(Sender: TObject);
procedure AcShowHeadersExecute(Sender: TObject);
procedure AcSortColAscExecute(Sender: TObject);
procedure AcSortExecute(Sender: TObject);
procedure AcTextRotationExecute(Sender: TObject);
procedure AcVertAlignmentExecute(Sender: TObject);
procedure AcViewInspectorExecute(Sender: TObject);
@ -344,7 +350,7 @@ implementation
uses
TypInfo, LCLIntf, LCLType,
fpcanvas, fpsutils, fpscsv,
sFormatSettingsForm, sCSVParamsForm;
sFormatSettingsForm, sCSVParamsForm, sSortParamsForm;
const
DROPDOWN_COUNT = 24;
@ -752,6 +758,54 @@ begin
WorksheetGrid.ShowHeaders := AcShowHeaders.Checked;
end;
procedure TMainFrm.AcSortColAscExecute(Sender: TObject);
var
c, r: Cardinal;
colIndexes: TsIndexArray;
begin
r := WorksheetGrid.GetWorksheetRow(WorksheetGrid.Row);
c := WorksheetGrid.GetWorksheetCol(WorksheetGrid.Col);
SetLength(colIndexes, 1);
colIndexes[0] := c;
with WorksheetGrid.Worksheet do
SortCols(ssoAscending, colIndexes, 0, c, GetLastOccupiedRowIndex, c);
end;
procedure TMainFrm.AcSortExecute(Sender: TObject);
var
F: TSortParamsForm;
indexes: TsIndexArray;
r1,c1,r2,c2: Cardinal;
begin
F := TSortParamsForm.Create(nil);
try
F.WorksheetGrid := WorksheetGrid;
if F.ShowModal = mrOK then
begin
indexes := F.SortIndex;
if Length(indexes) > 0 then
begin
// Limits of the range to be sorted
with WorksheetGrid do begin
r1 := GetWorksheetRow(Selection.Top);
c1 := GetWorksheetCol(Selection.Left);
r2 := GetWorksheetRow(Selection.Bottom);
c2 := GetWorksheetCol(Selection.Right);
end;
// Execute sorting. Use Begin/EndUpdate to avoid unnecessary redraws.
WorksheetGrid.BeginUpdate;
try
WorksheetGrid.Worksheet.Sort(F.SortByCols, ssoAscending, indexes, r1, c1, r2, c2)
finally
WorksheetGrid.EndUpdate;
end;
end;
end;
finally
F.Free;
end;
end;
procedure TMainFrm.AcTextRotationExecute(Sender: TObject);
var
text_rot: TsTextRotation;

12
components/fpspreadsheet/examples/spready/spready.lpi
View File

@ -92,7 +92,7 @@
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="5">
<Units Count="6">
<Unit0>
<Filename Value="spready.lpr"/>
<IsPartOfProject Value="True"/>
@ -111,10 +111,12 @@
<ComponentName Value="CSVParamsForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="sCSVParamsForm"/>
</Unit2>
<Unit3>
<Filename Value="sctrls.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="sCtrls"/>
</Unit3>
<Unit4>
<Filename Value="sformatsettingsform.pas"/>
@ -122,7 +124,15 @@
<ComponentName Value="FormatSettingsForm"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="sFormatsettingsForm"/>
</Unit4>
<Unit5>
<Filename Value="ssortparamsform.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="SortParamsForm"/>
<ResourceBaseClass Value="Form"/>
<UnitName Value="sSortParamsForm"/>
</Unit5>
</Units>
</ProjectOptions>
<CompilerOptions>

3
components/fpspreadsheet/examples/spready/spready.lpr
View File

@ -5,7 +5,7 @@ program spready;
uses
Interfaces, // this includes the LCL widgetset
Forms, mainform, laz_fpspreadsheet_visual,
sCSVParamsForm, sCtrls, sFormatSettingsForm;
sCSVParamsForm, sCtrls, sFormatSettingsForm, sSortParamsForm;
{$R *.res}
@ -14,6 +14,7 @@ begin
Application.CreateForm(TMainFrm, MainFrm);
MainFrm.BeforeRun;
Application.CreateForm(TFormatSettingsForm, FormatSettingsForm);
Application.CreateForm(TSortParamsForm, SortParamsForm);
Application.Run;
end.

106
components/fpspreadsheet/examples/spready/ssortparamsform.lfm Normal file
View File

@ -0,0 +1,106 @@
object SortParamsForm: TSortParamsForm
Left = 361
Height = 303
Top = 177
Width = 374
Caption = 'Sorting criteria'
ClientHeight = 303
ClientWidth = 374
LCLVersion = '1.3'
object ButtonPanel: TButtonPanel
Left = 6
Height = 38
Top = 259
Width = 362
OKButton.Name = 'OKButton'
OKButton.DefaultCaption = True
OKButton.OnClick = OKButtonClick
HelpButton.Name = 'HelpButton'
HelpButton.DefaultCaption = True
CloseButton.Name = 'CloseButton'
CloseButton.DefaultCaption = True
CancelButton.Name = 'CancelButton'
CancelButton.DefaultCaption = True
TabOrder = 0
ShowButtons = [pbOK, pbCancel]
end
object Grid: TStringGrid
Left = 0
Height = 203
Top = 50
Width = 374
Align = alClient
ColCount = 3
Columns = <
item
ButtonStyle = cbsPickList
Title.Caption = 'Column'
Width = 120
end
item
ButtonStyle = cbsPickList
PickList.Strings = (
'A to Z (ascending)'
'Z to A (descending)'
)
Title.Caption = 'Direction'
Width = 150
end>
DefaultColWidth = 100
Options = [goFixedVertLine, goFixedHorzLine, goVertLine, goHorzLine, goRangeSelect, goEditing, goAlwaysShowEditor, goSmoothScroll]
RowCount = 2
TabOrder = 1
TitleStyle = tsNative
Cells = (
1
0
1
'Sort by'
)
end
object Panel1: TPanel
Left = 0
Height = 50
Top = 0
Width = 374
Align = alTop
BevelOuter = bvNone
ClientHeight = 50
ClientWidth = 374
TabOrder = 2
object BtnAdd: TBitBtn
Left = 7
Height = 30
Top = 10
Width = 75
Caption = 'Add'
OnClick = BtnAddClick
TabOrder = 0
end
object BtnDelete: TBitBtn
Left = 87
Height = 30
Top = 10
Width = 75
Caption = 'Delete'
OnClick = BtnDeleteClick
TabOrder = 1
end
object CbSortColsRows: TComboBox
Left = 168
Height = 28
Top = 11
Width = 160
ItemHeight = 20
ItemIndex = 0
Items.Strings = (
'Sort top to bottom'
'Sort left to right'
)
OnChange = CbSortColsRowsChange
Style = csDropDownList
TabOrder = 2
Text = 'Sort top to bottom'
end
end
end

202
components/fpspreadsheet/examples/spready/ssortparamsform.pas Normal file
View File

@ -0,0 +1,202 @@
unit sSortParamsForm;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
ButtonPanel, Grids, ExtCtrls, Buttons, StdCtrls,
fpspreadsheet, fpspreadsheetgrid;
type
{ TSortParamsForm }
TSortParamsForm = class(TForm)
BtnAdd: TBitBtn;
BtnDelete: TBitBtn;
ButtonPanel: TButtonPanel;
CbSortColsRows: TComboBox;
Panel1: TPanel;
Grid: TStringGrid;
procedure BtnAddClick(Sender: TObject);
procedure BtnDeleteClick(Sender: TObject);
procedure CbSortColsRowsChange(Sender: TObject);
procedure OKButtonClick(Sender: TObject);
private
{ private declarations }
FWorksheetGrid: TsWorksheetGrid;
function GetSortByCols: Boolean;
function GetSortIndex: TsIndexArray;
procedure SetWorksheetGrid(AValue: TsWorksheetGrid);
procedure UpdateColRowList;
procedure UpdateCmds;
function ValidParams(out AMsg: String): Boolean;
public
{ public declarations }
property SortByCols: Boolean read GetSortByCols;
property SortIndex: TsIndexArray read GetSortIndex;
property WorksheetGrid: TsWorksheetGrid read FWorksheetGrid write SetWorksheetGrid;
end;
var
SortParamsForm: TSortParamsForm;
implementation
uses
fpsutils;
procedure TSortParamsForm.CbSortColsRowsChange(Sender: TObject);
begin
UpdateColRowList;
UpdateCmds;
end;
procedure TSortParamsForm.OKButtonClick(Sender: TObject);
var
msg: String;
begin
if not ValidParams(msg) then begin
MessageDlg(msg, mtError, [mbOK], 0);
ModalResult := mrNone;
end;
end;
procedure TSortParamsForm.BtnAddClick(Sender: TObject);
var
numConditions: Integer;
begin
case CbSortColsRows.ItemIndex of
0: numConditions := FWorksheetGrid.Selection.Right - FWorksheetGrid.Selection.Left + 1;
1: numConditions := FWorksheetGrid.Selection.Bottom - FWorksheetGrid.Selection.Top + 1;
end;
if Grid.RowCount - Grid.FixedRows >= numConditions then
exit; // there can't be more conditions than defined by the worksheetgrid selection
Grid.RowCount := Grid.RowCount + 1;
Grid.Cells[0, Grid.RowCount-1] := 'Then by';
UpdateCmds;
end;
procedure TSortParamsForm.BtnDeleteClick(Sender: TObject);
begin
if Grid.RowCount = Grid.FixedRows + 1 then
exit; // 1 condition must remain
Grid.DeleteRow(Grid.Row);
Grid.Cells[0, 1] := 'Sort by';
UpdateCmds;
end;
function TSortParamsForm.GetSortByCols: Boolean;
begin
Result := CbSortColsRows.ItemIndex = 0;
end;
function TSortParamsForm.GetSortIndex: TsIndexArray;
var
i, p: Integer;
s: String;
n: Cardinal;
begin
SetLength(Result, 0);
s:= Grid.Cells[0, 0];
s := Grid.Cells[0, 1];
for i:= Grid.FixedRows to Grid.RowCount-1 do
begin
s := Grid.Cells[1, i];
if s <> '' then
begin
p := pos(' ', s);
s := Copy(s, p+1, Length(s));
case CbSortColsRows.ItemIndex of
0: if not ParseCellColString(s, n) then continue; // row index
1: if not TryStrToInt(s, LongInt(n)) then continue else dec(n); // column index
end;
SetLength(Result, Length(Result)+1);
Result[Length(Result)-1] := n;
end;
end;
end;
procedure TSortParamsForm.SetWorksheetGrid(AValue: TsWorksheetGrid);
begin
FWorksheetGrid := AValue;
UpdateColRowList;
UpdateCmds;
end;
procedure TSortParamsForm.UpdateColRowList;
var
r,c, r1,c1, r2,c2: Cardinal;
L: TStrings;
begin
with FWorksheetGrid do begin
r1 := GetWorksheetRow(Selection.Top);
c1 := GetWorksheetCol(Selection.Left);
r2 := GetWorksheetRow(Selection.Bottom);
c2 := GetWorksheetCol(Selection.Right);
end;
L := TStringList.Create;
try
case CbSortColsRows.ItemIndex of
0: begin
Grid.RowCount := Grid.FixedRows + 1;
Grid.Columns[0].Title.Caption := 'Columns';
for c := c1 to c2 do
L.Add('Column ' + GetColString(c));
end;
1: begin
Grid.RowCount := Grid.FixedRows + 1;
Grid.Columns[0].Title.Caption := 'Rows';
for r := r1 to r2 do
L.Add('Row ' + IntToStr(r+1));
end;
end;
Grid.Columns[0].PickList.Assign(L);
for r := Grid.FixedRows to Grid.RowCount-1 do
begin
Grid.Cells[1, r] := '';
Grid.Cells[2, r] := ''
end;
finally
L.Free;
end;
end;
procedure TSortParamsForm.UpdateCmds;
var
r1,c1,r2,c2: Cardinal;
numConditions: Integer;
begin
with FWorksheetGrid do begin
r1 := GetWorksheetRow(Selection.Top);
c1 := GetWorksheetCol(Selection.Left);
r2 := GetWorksheetRow(Selection.Bottom);
c2 := GetWorksheetCol(Selection.Right);
end;
numConditions := Grid.RowCount - Grid.FixedRows;
case CbSortColsRows.ItemIndex of
0: BtnAdd.Enabled := numConditions < c2-c1+1;
1: BtnAdd.Enabled := numConditions < r2-r1+1;
end;
BtnDelete.Enabled := numConditions > 1;
end;
function TSortParamsForm.ValidParams(out AMsg: String): Boolean;
begin
Result := false;
if Length(SortIndex) = 0 then
begin
AMsg := 'No sorting criteria selected.';
Grid.SetFocus;
exit;
end;
Result := true;
end;
initialization
{$I ssortparamsform.lrs}
end.

340
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -442,7 +442,13 @@ type
{@@ Pointer to a TCol record }
PCol = ^TCol;
{@@ WSorksheet user interface options:
{@@ Row and column index array }
TsIndexArray = array of cardinal;
{@@ Sort order }
TsSortOrder = (ssoAscending, ssoDescending);
{@@ Worksheet user interface options:
@param soShowGridLines Show or hide the grid lines in the spreadsheet
@param soShowHeaders Show or hide the column or row headers of the spreadsheet
@param soHasFrozenPanes If set a number of rows and columns of the spreadsheet
@ -466,6 +472,11 @@ type
handled by TsWorksheetGrid to update the grid. }
TsCellEvent = procedure (Sender: TObject; ARow, ACol: Cardinal) of object;
{@@ This event can be used to override the built-in comparing function which
is called when cells are sorted. }
TsCellCompareEvent = procedure (Sender: TObject; ACell1, ACell2: PCell;
AResult: Integer) of object;
{@@ The worksheet contains a list of cells and provides a variety of methods
to read or write data to the cells, or to change their formatting. }
TsWorksheet = class
@ -483,8 +494,11 @@ type
FLastColIndex: Cardinal;
FDefaultColWidth: Single; // in "characters". Excel uses the width of char "0" in 1st font
FDefaultRowHeight: Single; // in "character heights", i.e. line count
FSortOrder: TsSortOrder;
FSortIndexes: TsIndexArray;
FOnChangeCell: TsCellEvent;
FOnChangeFont: TsCellEvent;
FOnCompareCells: TsCellCompareEvent;
{ Setter/Getter }
function GetFormatSettings: TFormatSettings;
@ -501,10 +515,18 @@ type
protected
function CellUsedInFormula(ARow, ACol: Cardinal): Boolean;
// Notification of changed cells content and format
procedure ChangedCell(ARow, ACol: Cardinal);
procedure ChangedFont(ARow, ACol: Cardinal);
procedure RemoveCell(ARow, ACol: Cardinal);
// Remove and delete cells
function RemoveCell(ARow, ACol: Cardinal): PCell;
procedure RemoveAndFreeCell(ARow, ACol: Cardinal);
// Sorting
function DoCompareCells(ACell1, ACell2: PCell): Integer;
procedure DoExchangeColRow(AIsColumn: Boolean; AIndex, WithIndex: Cardinal;
AFromIndex, AToIndex: Cardinal);
public
{@@ Name of the sheet. In the popular spreadsheet applications this is
@ -698,6 +720,7 @@ type
procedure CopyCell(AFromRow, AFromCol, AToRow, AToCol: Cardinal; AFromWorksheet: TsWorksheet);
procedure CopyFormat(AFormat: PCell; AToRow, AToCol: Cardinal); overload;
procedure CopyFormat(AFromCell, AToCell: PCell); overload;
procedure ExchangeCells(ARow1, ACol1, ARow2, ACol2: Cardinal);
function FindCell(ARow, ACol: Cardinal): PCell; overload;
function FindCell(AddressStr: String): PCell; overload;
function GetCell(ARow, ACol: Cardinal): PCell; overload;
@ -739,6 +762,18 @@ type
procedure WriteColInfo(ACol: Cardinal; AData: TCol);
procedure WriteColWidth(ACol: Cardinal; AWidth: Single);
// Sorting
procedure Sort(AColSorting: Boolean; ASortOrder: TsSortOrder;
ASortIndexes: TsIndexArray; ARowFrom, AColFrom, ARowTo, AColTo: Integer);
procedure SortCols(ASortOrder: TsSortOrder; ASortColumns: TsIndexArray;
ARowFrom, AColFrom, ARowTo, AColTo: Cardinal); overload;
procedure SortCols(ASortOrder: TsSortOrder; ASortColumns: TsIndexArray;
const ARange: String); overload;
procedure SortRows(ASortOrder: TsSortOrder; ASortRows: TsIndexArray;
ARowFrom, AColFrom, ARowTo, AColTo: Cardinal); overload;
procedure SortRows(ASortOrder: TsSortOrder; ASortRows: TsIndexArray;
const ARange: String); overload;
{ Properties }
{@@ List of cells of the worksheet. Only cells with contents or with formatting
@ -771,6 +806,8 @@ type
property OnChangeCell: TsCellEvent read FOnChangeCell write FOnChangeCell;
{@@ Event fired when the font size in a cell changes }
property OnChangeFont: TsCellEvent read FOnChangeFont write FOnChangeFont;
{@@ Event to override cell comparison for sorting }
property OnCompareCells: TsCellCompareEvent read FOnCompareCells write FOnCompareCells;
end;
{@@
@ -1890,6 +1927,36 @@ begin
end;
end;
{@@ ----------------------------------------------------------------------------
Exchanges two cells
@param ARow1 Row index of the first cell
@param ACol1 Column index of the first cell
@param ARow2 Row index of the second cell
@param ACol2 Column index of the second cell
-------------------------------------------------------------------------------}
procedure TsWorksheet.ExchangeCells(ARow1, ACol1, ARow2, ACol2: Cardinal);
var
cell1, cell2: PCell;
begin
cell1 := RemoveCell(ARow1, ACol1);
cell2 := RemoveCell(ARow2, ACol2);
if cell1 <> nil then
begin
cell1^.Row := ARow2;
cell1^.Col := ACol2;
FCells.Add(cell1);
ChangedCell(ARow2, ACol2);
end;
if cell2 <> nil then
begin
cell2^.Row := ARow1;
cell2^.Col := ACol1;
FCells.Add(cell2);
ChangedCell(ARow1, ACol1);
end;
end;
{@@ ----------------------------------------------------------------------------
Tries to locate a Cell in the list of already written Cells
@ -3085,6 +3152,19 @@ begin
FCells.Clear;
end;
{@@ ----------------------------------------------------------------------------
Removes a cell from its tree container. DOES NOT RELEASE ITS MEMORY!
@param ARow Row index of the cell to be removed
@param ACol Column index of the cell to be removed
@return Pointer to the cell removed
-------------------------------------------------------------------------------}
function TsWorksheet.RemoveCell(ARow, ACol: Cardinal): PCell;
begin
Result := FindCell(ARow, ACol);
if Result <> nil then FCells.Remove(Result);
end;
{@@ ----------------------------------------------------------------------------
Removes a cell and releases its memory.
Just for internal usage since it does not modify the other cells affects
@ -3092,7 +3172,7 @@ end;
@param ARow Row index of the cell to be removed
@param ACol Column index of the cell to be removed
--------------------------------------------------------------------------------}
procedure TsWorksheet.RemoveCell(ARow, ACol: Cardinal);
procedure TsWorksheet.RemoveAndFreeCell(ARow, ACol: Cardinal);
var
cellnode: TAVLTreeNode;
cell: TCell;
@ -3106,9 +3186,255 @@ begin
end;
end;
{@@ ----------------------------------------------------------------------------
Compare function for sorting of rows and columns
@param ACell1 Pointer to the first cell of the comparison
@param ACell2 Pointer to the second cell of the comparison
@return -1 if the first cell is "smaller"
+1 if the first cell is "larger",
0 if both cells are "equal"
Date/time and boolean cells are sorted like number cells according
to their number value
Label cells are sorted like UTF8 strings.
In case of different cell content types used in the comparison:
Empty cells are "smallest", Label cells are next, Numeric cells
are "largest"
-------------------------------------------------------------------------------}
function TsWorksheet.DoCompareCells(ACell1, ACell2: PCell): Integer;
// Sort priority in Excel:
// blank < alpha < number, dates are sorted according to their number value
var
number1, number2: Double;
begin
result := 0;
if Assigned(OnCompareCells) then
OnCompareCells(Self, ACell1, ACell2, Result)
else
begin
if (ACell1 = nil) and (ACell2 = nil) then
Result := 0
else
if (ACell1 = nil) then
Result := -1
else
if (ACell2 = nil) then
Result := +1
else
if (ACell1^.ContentType = cctEmpty) and (ACell2^.ContentType = cctEmpty) then
Result := 0
else if (ACell1^.ContentType = cctEmpty) then
Result := -1
else if (ACell2^.ContentType = cctEmpty) then
Result := +1
else if (ACell1^.ContentType = cctUTF8String) and (ACell2^.ContentType = cctUTF8String) then
Result := CompareText(ACell1^.UTF8StringValue, ACell2^.UTF8StringValue)
else if (ACell1^.ContentType = cctUTF8String) and (ACell2^.ContentType <> cctUTF8String) then
Result := -1
else
if (ACell1^.ContentType <> cctUTF8String) and (ACell2^.ContentType = cctUTF8String) then
Result := +1
else
begin
ReadNumericValue(ACell1, number1);
ReadNumericValue(ACell2, number2);
Result := CompareValue(number1, number2);
end;
end;
if FSortOrder = ssoDescending then Result := -Result;
end;
{@@ ----------------------------------------------------------------------------
Exchanges columns or rows, depending on value of "AIsColumn"
@param AIsColumn if true the exchange is done for columns, otherwise for rows
@param AIndex Index of the column (if AIsColumn is true) or the row
(if AIsColumn is false) which is to be exchanged with the
one having index "WidthIndex"
@param WithIndex Index of the column (if AIsColumn is true) or the row
(if AIsColumn is false) with which "AIndex" is to be
replaced.
@param AFromIndex First row (if AIsColumn is true) or column (if AIsColumn
is false) which is affected by the exchange
@param AToIndex Last row (if AIsColumn is true) or column (if AsColumn is
false) which is affected by the exchange
-------------------------------------------------------------------------------}
procedure TsWorksheet.DoExchangeColRow(AIsColumn: Boolean;
AIndex, WithIndex: Cardinal; AFromIndex, AToIndex: Cardinal);
var
r, c: Cardinal;
begin
if AIsColumn then
for r := AFromIndex to AToIndex do
ExchangeCells(r, AIndex, r, WithIndex)
else
for c := AFromIndex to AToIndex do
ExchangeCells(AIndex, c, WithIndex, c);
end;
{@@ ----------------------------------------------------------------------------
-------------------------------------------------------------------------------}
procedure TsWorksheet.Sort(AColSorting: Boolean; ASortOrder: TsSortOrder;
ASortIndexes: TsIndexArray; ARowFrom, AColFrom, ARowTo, AColTo: Integer);
procedure QuickSort(L,R: Integer);
var
I,J,K: Integer;
P: Integer;
cell1, cell2: PCell;
compareResult: Integer;
begin
repeat
I := L;
J := R;
P := (L+R) div 2;
repeat
if AColSorting then
begin
K := 0;
repeat
cell1 := FindCell(P, ASortIndexes[K]);
cell2 := FindCell(I, ASortIndexes[K]);
compareResult := DoCompareCells(cell1, cell2);
case compareResult of
-1: break;
0: if K < High(ASortIndexes) then
inc(K)
else
break;
+1: inc(I);
end;
until false;
K := 0;
repeat
cell1 := FindCell(P, ASortIndexes[K]);
cell2 := FindCell(J, ASortIndexes[K]);
compareResult := DoCompareCells(cell1, cell2);
case compareResult of
-1: dec(J);
0: if K < High(ASortIndexes) then
inc(K)
else
break;
+1: break;
end;
until false;
end else
begin
K := 0;
repeat
cell1 := FindCell(ASortIndexes[K], P);
cell2 := FindCell(ASortIndexes[K], I);
compareResult := DoCompareCells(cell1, cell2);
case compareResult of
-1: break;
0: if K < High(ASortIndexes) then
inc(K)
else
break;
+1: inc(I);
end;
until False;
K := 0;
repeat
cell1 := FindCell(ASortIndexes[K], P);
cell2 := FindCell(ASortIndexes[K], J);
compareResult := DoCompareCells(cell1, cell2);
case compareResult of
-1: dec(J);
0: if K < High(ASortIndexes) then
inc(K)
else
break;
+1: break;
end;
until false;
end;
if I <= J then
begin
if I <> J then
begin
if AColSorting then
begin
cell1 := FindCell(I, ASortIndexes[0]);
cell2 := FIndCell(J, ASortIndexes[0]);
if DoCompareCells(cell1, cell2) <> 0 then
DoExchangeColRow(not AColSorting, J,I, AColFrom, AColTo);
end else
begin
cell1 := FindCell(ASortIndexes[0], I);
cell2 := FIndCell(ASortIndexes[0], J);
if DoCompareCells(cell1, cell2) <> 0 then
DoExchangeColRow(not AColSorting, J,I, ARowFrom, ARowTo);
end;
end;
if P = I then
P := J
else
if P = J then
P := I;
inc(I);
dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end;
begin
FSortOrder := ASortOrder;
FSortIndexes := ASortIndexes;
if AColSorting then
QuickSort(ARowFrom, ARowTo)
else
QuickSort(AColFrom, AColTo);
ChangedCell(ARowFrom, AColFrom);
end;
procedure TsWorksheet.SortCols(ASortOrder: TsSortOrder; ASortColumns: TsIndexArray;
const ARange: String);
var
r1,c1, r2,c2: Cardinal;
begin
if ParseCellRangeString(ARange, r1, c1, r2, c2) then
SortCols(ASortOrder, ASortColumns, r1, c1, r2, c2);
end;
procedure TsWorksheet.SortCols(ASortOrder: TsSortOrder; ASortColumns: TsIndexArray;
ARowFrom, AColFrom, ARowTo, AColTo: Cardinal);
begin
Sort(true, ASortOrder, ASortColumns, ARowFrom, AColFrom, ARowTo, AColTo);
end;
procedure TsWorksheet.SortRows(ASortOrder: TsSortOrder; ASortRows: TsIndexArray;
const ARange: String);
var
r1,c1, r2,c2: Cardinal;
begin
if ParseCellRangeString(ARange, r1, c1, r2, c2) then
SortRows(ASortOrder, ASortRows, r1, c1, r2, c2);
end;
procedure TsWorksheet.SortRows(ASortOrder: TsSortOrder; ASortRows: TsIndexArray;
ARowFrom, AColFrom, ARowTo, AColTo: Cardinal);
begin
Sort(false, ASortOrder, ASortRows, ARowFrom, AColFrom, ARowTo, AColTo);
end;
{@@ ----------------------------------------------------------------------------
Helper method to update internal caching variables
--------------------------------------------------------------------------------}
-------------------------------------------------------------------------------}
procedure TsWorksheet.UpdateCaches;
begin
FFirstColIndex := GetFirstColIndex(true);
@ -3467,7 +3793,7 @@ begin
begin
r := ACell^.Row;
c := ACell^.Col;
RemoveCell(r, c);
RemoveAndFreeCell(r, c);
end
else
WriteBlank(ACell);
@ -5082,7 +5408,7 @@ begin
// Delete cells
for r := lastRow downto firstRow do
RemoveCell(r, ACol);
RemoveAndFreeCell(r, ACol);
// Update column index of cell records
cellnode := FCells.FindLowest;
@ -5171,7 +5497,7 @@ begin
// Delete cells
for c := lastCol downto 0 do
RemoveCell(ARow, c);
RemoveAndFreeCell(ARow, c);
// Update row index of cell reocrds
cellnode := FCells.FindLowest;