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

fpspreadsheet: Rework of worksheet sorting, patch by Zoran (https://forum.lazarus.freepascal.org/index.php/topic,45474.msg321648.html).

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@7011 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2019-06-17 12:08:12 +00:00
parent ffacd7bcca
commit 7585c5a3c9
3 changed files with 64 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

92
components/fpspreadsheet/source/common/fpspreadsheet.pas
View File

@ -53,6 +53,11 @@ type
TsCellCompareEvent = procedure (Sender: TObject; ACell1, ACell2: PCell; TsCellCompareEvent = procedure (Sender: TObject; ACell1, ACell2: PCell;
var AResult: Integer) of object; var AResult: Integer) of object;
{@@ This event can be used to override the built-in comparing function which
is called when cells are sorted. }
TsCellFullCompareEvent = procedure (Sender: TObject; ACell1, ACell2: PCell;
ASortKey: TsSortKey; var AResult: Integer) of object;
{@@ Event fired when writing a file in virtual mode. The event handler has to {@@ Event fired when writing a file in virtual mode. The event handler has to
pass data ("AValue") and formatting style to be copied from a template pass data ("AValue") and formatting style to be copied from a template
cell ("AStyleCell") to the writer } cell ("AStyleCell") to the writer }
@ -98,6 +103,7 @@ type
FOnChangeRow: TsRowEvent; FOnChangeRow: TsRowEvent;
FOnZoom: TsNotifyEvent; FOnZoom: TsNotifyEvent;
FOnCompareCells: TsCellCompareEvent; FOnCompareCells: TsCellCompareEvent;
FOnFullCompareCells: TsCellFullCompareEvent;
FOnSelectCell: TsCellEvent; FOnSelectCell: TsCellEvent;
FOnWriteCellData: TsWorksheetWriteCellDataEvent; FOnWriteCellData: TsWorksheetWriteCellDataEvent;
@ -484,8 +490,7 @@ type
AColWidthType: TsColWidthType = cwtCustom); overload; deprecated 'Use version with parameter AUnits'; AColWidthType: TsColWidthType = cwtCustom); overload; deprecated 'Use version with parameter AUnits';
// Sorting // Sorting
function DefaultCompareCells(ACell1, ACell2: PCell; function DefaultCompareCells(ACell1, ACell2: PCell; ASortKey: TsSortKey): Integer;
ASortOptions: TsSortOptions): Integer;
procedure Sort(const ASortParams: TsSortParams; procedure Sort(const ASortParams: TsSortParams;
ARowFrom, AColFrom, ARowTo, AColTo: Cardinal); overload; ARowFrom, AColFrom, ARowTo, AColTo: Cardinal); overload;
procedure Sort(ASortParams: TsSortParams; ARange: String); overload; procedure Sort(ASortParams: TsSortParams; ARange: String); overload;
@ -649,7 +654,10 @@ type
{@@ Event fired when a row height or row formatting has changed } {@@ Event fired when a row height or row formatting has changed }
property OnChangeRow: TsRowEvent read FOnChangeRow write FOnChangeRow; property OnChangeRow: TsRowEvent read FOnChangeRow write FOnChangeRow;
{@@ Event to override cell comparison for sorting } {@@ Event to override cell comparison for sorting }
property OnCompareCells: TsCellCompareEvent read FOnCompareCells write FOnCompareCells; property OnCompareCells: TsCellCompareEvent
read FOnCompareCells write FOnCompareCells; deprecated 'Use OnFullCompareCells instead';
{@@ Event to override cell comparison for sorting }
property OnFullCompareCells: TsCellFullCompareEvent read FOnFullCompareCells write FOnFullCompareCells;
{@@ Event fired when a cell is "selected". } {@@ Event fired when a cell is "selected". }
property OnSelectCell: TsCellEvent read FOnSelectCell write FOnSelectCell; property OnSelectCell: TsCellEvent read FOnSelectCell write FOnSelectCell;
{@@ This event allows to provide external cell data for writing to file, {@@ This event allows to provide external cell data for writing to file,
@ -4068,7 +4076,7 @@ begin
Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY); Result := WriteImage(ARow, ACol, idx, AOffsetX, AOffsetY, AScaleX, AScaleY);
end; end;
function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AImageIndex: integer; function TsWorksheet.WriteImage(ARow, ACol: Cardinal; AImageIndex: Integer;
AOffsetX: Double = 0.0; AOffsetY: Double = 0.0; AOffsetX: Double = 0.0; AOffsetY: Double = 0.0;
AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer; AScaleX: Double = 1.0; AScaleY: Double = 1.0): Integer;
var var
@ -4304,10 +4312,12 @@ begin
cell1 := FindCell(FSortParams.Keys[key].ColRowIndex, AColRow1); cell1 := FindCell(FSortParams.Keys[key].ColRowIndex, AColRow1);
cell2 := FindCell(FSortParams.Keys[key].ColRowIndex, AColRow2); cell2 := FindCell(FSortParams.Keys[key].ColRowIndex, AColRow2);
end; end;
if Assigned(OnCompareCells) then if Assigned(FOnFullCompareCells) then
OnCompareCells(Self, cell1, cell2, Result) FOnFullCompareCells(Self, cell1, cell2, FSortParams.Keys[Key], Result)
else if Assigned(FOnCompareCells) then
FOnCompareCells(Self, cell1, cell2, Result)
else else
Result := DefaultCompareCells(cell1, cell2, FSortParams.Keys[key].Options); Result := DefaultCompareCells(cell1, cell2, FSortParams.Keys[key]);
inc(key); inc(key);
end; end;
end; end;
@ -4317,7 +4327,8 @@ end;
@param ACell1 Pointer to the first cell of the comparison @param ACell1 Pointer to the first cell of the comparison
@param ACell2 Pointer to the second cell of the comparison @param ACell2 Pointer to the second cell of the comparison
@param ASortOptions Options for sorting: descending and/or case-insensitive @param ASortKey Sorting criteria: sorted column/row, descending,
case-insensitive, numbers first, etc.
@return -1 if the first cell is "smaller" @return -1 if the first cell is "smaller"
+1 if the first cell is "larger", +1 if the first cell is "larger",
0 if both cells are "equal" 0 if both cells are "equal"
@ -4332,7 +4343,7 @@ end;
order) order)
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.DefaultCompareCells(ACell1, ACell2: PCell; function TsWorksheet.DefaultCompareCells(ACell1, ACell2: PCell;
ASortOptions: TsSortOptions): Integer; ASortKey: TsSortKey): Integer;
// Sort priority in Excel: // Sort priority in Excel:
// numbers < alpha < blank (ascending) // numbers < alpha < blank (ascending)
// alpha < numbers < blank (descending) // alpha < numbers < blank (descending)
@ -4341,17 +4352,12 @@ var
begin begin
Result := 0; Result := 0;
if ((ACell1 = nil) or (ACell1^.ContentType = cctEmpty)) and if (ACell1 = nil) or (ACell1^.ContentType = cctEmpty)
((ACell2 = nil) or (ACell2^.ContentType = cctEmpty))
then begin then begin
Result := 0; if (ACell2 <> nil) and (ACell2^.ContentType <> cctEmpty) then
exit;
end;
if (ACell1 = nil) or (ACell1^.ContentType = cctEmpty) then
begin
Result := +1; // Empty cells go to the end Result := +1; // Empty cells go to the end
exit; // Avoid SortOrder to bring the empty cell to the top!
Exit; // Avoid SortOrder to bring the empty cell to the top!
end; end;
if (ACell2 = nil) or (ACell2^.ContentType = cctEmpty) then if (ACell2 = nil) or (ACell2^.ContentType = cctEmpty) then
@ -4360,32 +4366,38 @@ begin
exit; // Avoid SortOrder to bring the empty cell to the top! exit; // Avoid SortOrder to bring the empty cell to the top!
end; end;
if (ACell1^.ContentType = cctUTF8String) and (ACell2^.ContentType = cctUTF8String) then if (ACell1^.ContentType = cctUTF8String) then begin
if (ACell2^.ContentType = cctUTF8String) then
begin begin
if ssoCaseInsensitive in ASortOptions then if ssoCaseInsensitive in ASortKey.Options then
Result := UTF8CompareText(ACell1^.UTF8StringValue, ACell2^.UTF8StringValue) Result := AnsiCompareText(ACell1^.UTF8StringValue, ACell2^.UTF8StringValue)
else else
Result := UTF8CompareStr(ACell1^.UTF8StringValue, ACell2^.UTF8StringValue); Result := AnsiCompareStr(ACell1^.UTF8StringValue, ACell2^.UTF8StringValue);
end else end else
if (ACell1^.ContentType = cctUTF8String) and (ACell2^.ContentType <> cctUTF8String) then begin
case FSortParams.Priority of if ssoAlphaBeforeNum in ASortKey.Options then
spNumAlpha: Result := +1; // numbers before text Result := -1
spAlphaNum: Result := -1; // text before numbers
end
else else
if (ACell1^.ContentType <> cctUTF8String) and (ACell2^.ContentType = cctUTF8String) then Result := 1;
case FSortParams.Priority of end;
spNumAlpha: Result := -1;
spAlphaNum: Result := +1; end else
end begin
if (ACell2^.ContentType = cctUTF8String) then
begin
if ssoAlphaBeforeNum in ASortKey.Options then
Result := +1
else else
Result := -1;
end else
begin begin
ReadNumericValue(ACell1, number1); ReadNumericValue(ACell1, number1);
ReadNumericValue(ACell2, number2); ReadNumericValue(ACell2, number2);
Result := CompareValue(number1, number2); Result := CompareValue(number1, number2);
end; end;
end;
if ssoDescending in ASortOptions then if ssoDescending in ASortKey.Options then
Result := -Result; Result := -Result;
end; end;
@ -4711,7 +4723,7 @@ end;
{@@ ---------------------------------------------------------------------------- {@@ ----------------------------------------------------------------------------
Setter method for the zoom factor Setter method for the zoom factor
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
procedure TsWorksheet.SetZoomfactor(AValue: Double); procedure TsWorksheet.SetZoomFactor(AValue: Double);
begin begin
if AValue = FZoomFactor then exit; if AValue = FZoomFactor then exit;
FZoomFactor := AValue; FZoomFactor := AValue;
@ -4894,7 +4906,7 @@ end;
@return Pointer to cell created or used @return Pointer to cell created or used
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: double): PCell; function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: Double): PCell;
begin begin
Result := GetCell(ARow, ACol); Result := GetCell(ARow, ACol);
WriteNumber(Result, ANumber); WriteNumber(Result, ANumber);
@ -4931,7 +4943,7 @@ end;
@return Pointer to cell created or used @return Pointer to cell created or used
@see TsNumberFormat @see TsNumberFormat
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: double; function TsWorksheet.WriteNumber(ARow, ACol: Cardinal; ANumber: Double;
ANumFormat: TsNumberFormat; ADecimals: Byte = 2; ANumFormat: TsNumberFormat; ADecimals: Byte = 2;
AMinIntDigits: Integer = 1): PCell; AMinIntDigits: Integer = 1): PCell;
begin begin
@ -5824,7 +5836,7 @@ end;
uses dot and comma, respectively. uses dot and comma, respectively.
@return Pointer to the cell @return Pointer to the cell
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.WriteFormula(ARow, ACol: Cardinal; AFormula: string; function TsWorksheet.WriteFormula(ARow, ACol: Cardinal; AFormula: String;
ALocalized: Boolean = false): PCell; ALocalized: Boolean = false): PCell;
begin begin
Result := GetCell(ARow, ACol); Result := GetCell(ARow, ACol);
@ -5842,7 +5854,7 @@ end;
separators of the workbook's FormatSettings. Otherwise separators of the workbook's FormatSettings. Otherwise
uses dot and comma, respectively. uses dot and comma, respectively.
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
procedure TsWorksheet.WriteFormula(ACell: PCell; AFormula: string; procedure TsWorksheet.WriteFormula(ACell: PCell; AFormula: String;
ALocalized: Boolean = false); ALocalized: Boolean = false);
var var
parser: TsExpressionParser = nil; parser: TsExpressionParser = nil;
@ -6941,7 +6953,7 @@ end;
@see WriteBorderStyles @see WriteBorderStyles
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
function TsWorksheet.WriteBorderStyle(ARow, ACol: Cardinal; function TsWorksheet.WriteBorderStyle(ARow, ACol: Cardinal;
ABorder: TsCellBorder; ALineStyle: TsLinestyle; AColor: TsColor): PCell; ABorder: TsCellBorder; ALineStyle: TsLineStyle; AColor: TsColor): PCell;
begin begin
Result := GetCell(ARow, ACol); Result := GetCell(ARow, ACol);
WriteBorderStyle(Result, ABorder, ALineStyle, AColor); WriteBorderStyle(Result, ABorder, ALineStyle, AColor);
@ -6959,7 +6971,7 @@ end;
@see WriteBorderStyles @see WriteBorderStyles
-------------------------------------------------------------------------------} -------------------------------------------------------------------------------}
procedure TsWorksheet.WriteBorderStyle(ACell: PCell; ABorder: TsCellBorder; procedure TsWorksheet.WriteBorderStyle(ACell: PCell; ABorder: TsCellBorder;
ALineStyle: TsLinestyle; AColor: TsColor); ALineStyle: TsLineStyle; AColor: TsColor);
var var
fmt: TsCellFormat; fmt: TsCellFormat;
begin begin

2
components/fpspreadsheet/source/common/fpstypes.pas
View File

@ -627,7 +627,7 @@ type
end; end;
{@@ Options for sorting } {@@ Options for sorting }
TsSortOption = (ssoDescending, ssoCaseInsensitive); TsSortOption = (ssoDescending, ssoCaseInsensitive, ssoAlphaBeforeNum);
{@@ Set of options for sorting } {@@ Set of options for sorting }
TsSortOptions = set of TsSortOption; TsSortOptions = set of TsSortOption;

3
components/fpspreadsheet/source/common/fpsutils.pas
View File

@ -2362,6 +2362,9 @@ begin
SetLength(Result.Keys, ANumSortKeys); SetLength(Result.Keys, ANumSortKeys);
for i:=0 to High(Result.Keys) do begin for i:=0 to High(Result.Keys) do begin
Result.Keys[i].ColRowIndex := i; Result.Keys[i].ColRowIndex := i;
if ASortPriority = spAlphaNum then
Result.Keys[I].Options := [ssoAlphaBeforeNum]
else
Result.Keys[i].Options := []; // Ascending & case-sensitive Result.Keys[i].Options := []; // Ascending & case-sensitive
end; end;
end; end;