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

fpspreadsheet: Beginning with infrastructure for merging of cells

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3534 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
wp_xxyyzz
2014-09-09 15:51:56 +00:00
parent d202dc7917
commit e277e09850
4 changed files with 287 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -454,9 +454,9 @@ object Form1: TForm1
Height = 457
Top = 79
Width = 231
ActivePage = PgCellValue
ActivePage = PgProperties
Align = alRight
TabIndex = 0
TabIndex = 1
TabOrder = 6
OnChange = InspectorPageControlChange
object PgCellValue: TTabSheet
@ -1224,6 +1224,15 @@ object Form1: TForm1
Action = AcWordwrap
AutoCheck = True
end
object MenuItem67: TMenuItem
Caption = '-'
end
object MenuItem68: TMenuItem
Action = AcMergeCells
end
object MenuItem69: TMenuItem
Action = AcUnmergeCells
end
end
object mnuView: TMenuItem
Caption = 'View'
@ -2868,11 +2877,24 @@ object Form1: TForm1
OnExecute = AcAddRowExecute
end
object AcViewInspector: TAction
Category = 'View'
AutoCheck = True
Caption = 'Inspector'
Checked = True
OnExecute = AcViewInspectorExecute
end
object AcMergeCells: TAction
Category = 'Format'
Caption = 'Merge cells'
Hint = 'Merge selected cells'
OnExecute = AcMergeCellsExecute
end
object AcUnmergeCells: TAction
Category = 'Format'
Caption = 'Un-merge cells'
Hint = 'Disconnect merged cells'
OnExecute = AcUnmergeCellsExecute
end
end
object FontDialog: TFontDialog
MinFontSize = 0

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

@ -71,6 +71,8 @@ type
AcNew: TAction;
AcAddColumn: TAction;
AcAddRow: TAction;
AcMergeCells: TAction;
AcUnmergeCells: TAction;
AcViewInspector: TAction;
AcWordwrap: TAction;
AcVAlignDefault: TAction;
@ -153,6 +155,9 @@ type
MenuItem64: TMenuItem;
MenuItem65: TMenuItem;
MenuItem66: TMenuItem;
MenuItem67: TMenuItem;
MenuItem68: TMenuItem;
MenuItem69: TMenuItem;
mnuInspector: TMenuItem;
mnuView: TMenuItem;
MnuFmtDateTimeMSZ: TMenuItem;
@ -253,12 +258,14 @@ type
procedure AcFontStyleExecute(Sender: TObject);
procedure AcHorAlignmentExecute(Sender: TObject);
procedure AcIncDecDecimalsExecute(Sender: TObject);
procedure AcMergeCellsExecute(Sender: TObject);
procedure AcNewExecute(Sender: TObject);
procedure AcNumFormatExecute(Sender: TObject);
procedure AcOpenExecute(Sender: TObject);
procedure AcQuitExecute(Sender: TObject);
procedure AcSaveAsExecute(Sender: TObject);
procedure AcTextRotationExecute(Sender: TObject);
procedure AcUnmergeCellsExecute(Sender: TObject);
procedure AcVertAlignmentExecute(Sender: TObject);
procedure AcViewInspectorExecute(Sender: TObject);
procedure AcWordwrapExecute(Sender: TObject);
@ -528,6 +535,11 @@ begin
end;
end;
procedure TForm1.AcMergeCellsExecute(Sender: TObject);
begin
WorksheetGrid.MergeCells;
end;
procedure TForm1.AcNewExecute(Sender: TObject);
begin
WorksheetGrid.NewWorkbook(26, 100);
@ -609,6 +621,11 @@ begin
UpdateTextRotationActions;
end;
procedure TForm1.AcUnmergeCellsExecute(Sender: TObject);
begin
WorksheetGrid.UnmergeCells;
end;
procedure TForm1.AcVertAlignmentExecute(Sender: TObject);
var
vert_align: TsVertAlignment;
@ -968,6 +985,7 @@ var
i: Integer;
s: String;
cb: TsCellBorder;
r1,r2,c1,c2: Cardinal;
begin
with CellInspector do begin
TitleCaptions[0] := 'Properties';
@ -1060,6 +1078,13 @@ begin
if (ACell=nil) or not (uffNumberFormat in ACell^.UsedFormattingFields)
then Strings.Add('NumberFormatStr=')
else Strings.Add('NumberFormatStr=' + ACell^.NumberFormatStr);
if (ACell=nil) or (ACell^.MergedNeighbors = []) then
Strings.Add('Not merged=')
else begin
WorksheetGrid.Worksheet.FindMergedRange(ACell, r1, c1, r2, c2);
Strings.Add('Belongs to merged range=' + GetCellRangeString(r1, c1, r2, c2));
end;
end;
end;
end;

220
components/fpspreadsheet/fpspreadsheet.pas
View File

@ -426,13 +426,13 @@ type
ContentType: TCellContentType;
{ Possible values for the cells }
FormulaValue: string;
// RPNFormulaValue: TsRPNFormula;
NumberValue: double;
UTF8StringValue: ansistring;
DateTimeValue: TDateTime;
BoolValue: Boolean;
ErrorValue: TsErrorValue;
SharedFormulaBase: PCell; // Cell containing the shared formula
MergedNeighbors: TsCellBorders;
{ Formatting fields }
{ When adding/deleting formatting fields don't forget to update CopyFormat! }
UsedFormattingFields: TsUsedFormattingFields;
@ -571,6 +571,14 @@ type
function ReadUsedFormatting(ARow, ACol: Cardinal): TsUsedFormattingFields;
function ReadBackgroundColor(ARow, ACol: Cardinal): TsColor;
{ Merging of cells }
procedure MergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal); overload;
procedure MergeCells(ARange: String); overload;
procedure UnmergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal); overload;
procedure UnmergeCells(ARange: String); overload;
function FindMergeBase(ACell: PCell): PCell;
function FindMergedRange(ACell: PCell; out ARow1, ACol1, ARow2, ACol2: Cardinal): Boolean;
{ Writing of values }
function WriteBlank(ARow, ACol: Cardinal): PCell; overload;
procedure WriteBlank(ACell: PCell); overload;
@ -2881,6 +2889,216 @@ begin
Result := ACell^.BackgroundColor;
end;
{@@
Merges adjacent individual cells to a larger single cell
@param ARow1 Row index of the upper left corner of the cell range
@param ACol1 Column index of the upper left corner of the cell range
@param ARow2 Row index of the lower right corner of the cell range
@param ACol2 Column index of the lower right corner of the cell range
}
procedure TsWorksheet.MergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal);
var
cell: PCell;
base: PCell;
r, c: Cardinal;
begin
// Case 1: single cell
if (ARow1 = ARow2) and (ACol1 = ACol2) then
exit;
// Case 2: single row
if (ARow1 = ARow2) and (ACol1 <> ACol2) then begin
cell := GetCell(ARow1, ACol1);
cell^.MergedNeighbors := [cbEast];
cell := GetCell(ARow2, ACol2);
cell^.MergedNeighbors := [cbWest];
for c := ACol1+1 to ACol2-1 do begin
cell := GetCell(ARow1, c);
cell^.MergedNeighbors := [cbEast, cbWest];
end;
end else
// Case 3: single column
if (ARow1 <> ARow2) and (ACol1 = ACol2) then begin
cell := GetCell(ARow1, ACol1);
cell^.MergedNeighbors := [cbSouth];
cell := GetCell(ARow2, ACol2);
cell^.MergedNeighbors := [cbNorth];
for r := ARow1+1 to ARow2-1 do begin
cell := GetCell(r, ACol1);
cell^.MergedNeighbors := [cbNorth, cbSouth];
end;
end else
// case 4: general case
begin
// left/top corner
cell := GetCell(ARow1, ACol1);
cell^.MergedNeighbors := [cbEast, cbSouth];
// right/top corner
cell := GetCell(ARow1, ACol2);
cell^.MergedNeighbors := [cbWest, cbSouth];
// left/bottom corner
cell := GetCell(ARow2, ACol1);
cell^.MergedNeighbors := [cbEast, cbNorth];
// right/bottom corner
cell := GetCell(ARow2, ACol2);
cell^.MergedNeighbors := [cbWest, cbNorth];
// top row
for c := ACol1+1 to ACol2-1 do begin
cell := GetCell(ARow1, c);
cell^.MergedNeighbors := [cbSouth, cbEast, cbWest];
end;
// bottom row
for c := ACol1+1 to ACol2-1 do begin
cell := GetCell(ARow2, c);
cell^.MergedNeighbors := [cbNorth, cbEast, cbWest];
end;
// left column
for r := ARow1+1 to ARow2-1 do begin
cell := GetCell(r, ACol1);
cell^.MergedNeighbors := [cbEast, cbNorth, cbSouth];
end;
// right column
for r := ARow1+1 to ARow2-1 do begin
cell := GetCell(r, ACol2);
cell^.MergedNeighbors := [cbWest, cbNorth, cbSouth];
end;
// inner
for r := ARow1+1 to ARow2-1 do
for c := ACol1+1 to ACol2-1 do begin
cell := GetCell(r, c);
cell^.MergedNeighbors := [cbEast, cbWest, cbNorth, cbSouth];
end;
end;
ChangedCell(ARow1, ACol1);
end;
{@@
Merges adjacent individual cells to a larger single cell
@param ARange Cell range string given in Excel notation (e.g: A1:D5)
}
procedure TsWorksheet.MergeCells(ARange: String);
var
r1, r2, c1, c2: Cardinal;
begin
if ParseCellRangeString(ARange, r1, c1, r2, c2) then
MergeCells(r1, c1, r2, c2);
end;
{@@
Disconnects merged cells to make them individual cells again.
@param ARow1 Row index of the upper left corner of the merged cell range
@param ACol1 Column index of the upper left corner of the mergec cell range
@param ARow2 Row index of the lower right corner of the merged cell range
@param ACol2 Column index of the lower right corner of the merged cell range
}
procedure TsWorksheet.UnmergeCells(ARow1, ACol1, ARow2, ACol2: Cardinal);
var
cell: PCell;
r, c: Cardinal;
begin
for r := ARow1 to ARow2 do
for c := ACol1 to ACol2 do
begin
cell := FindCell(r, c);
if cell <> nil then
cell^.MergedNeighbors := [];
end;
ChangedCell(ARow1, ACol1);
end;
{@@
Disconnects merged cells to make them individual cells again.
@param ARange Cell range string given in Excel notation (e.g: A1:D5)
}
procedure TsWorksheet.UnmergeCells(ARange: String);
var
r1, r2, c1, c2: Cardinal;
begin
if ParseCellRangeString(ARange, r1, c1, r2, c2) then
UnmergeCells(r1, c1, r2, c2);
end;
{@@
Finds the upper left cell of a merged block to which a specified cell belongs.
This is the "merge base". Returns nil if the cell is not merged.
@param ACell Cell under investigation
@return A pointer to the cell in the upper left corner of the merged block
to which ACell belongs, If ACell is isolated then the function returns
nil.
}
function TsWorksheet.FindMergeBase(ACell: PCell): PCell;
var
r, c: Cardinal;
begin
Result := ACell;
if (ACell = nil) or (ACell^.MergedNeighbors = []) then
exit;
r := Result^.Row;
c := Result^.Col;
while (cbNorth in Result^.MergedNeighbors) do begin
dec(r);
Result := FindCell(r, c);
end;
while (cbWest in Result^.MergedNeighbors) do begin
dec(c);
Result := FindCell(r, c);
end;
end;
{@@
Determines the merged cell block to which a given cell belongs
@param ACell Pointer to the cell being investigated
@param ARow1 (output) Top row index of the merged block
@param ACol1 (outout) Left column index of the merged block
@param ARow2 (output) Bottom row index of the merged block
@param ACol2 (output) Right column index of the merged block
@return True if the cell belongs to a merged block, False if not, or if the
cell does not exist at all.
}
function TsWorksheet.FindMergedRange(ACell: PCell;
out ARow1, ACol1, ARow2, ACol2: Cardinal): Boolean;
var
r, c: Cardinal;
cell: PCell;
begin
cell := FindMergeBase(ACell);
if cell = nil then begin
Result := false;
exit;
end;
ARow1 := cell^.Row;
ACol1 := cell^.Col;
ARow2 := ARow1;
while (cell <> nil) and (cbSouth in cell^.MergedNeighbors) do begin
inc(ARow2);
cell := FindCell(ARow2, ACol1);
end;
if cell = nil then begin
Result := false;
exit;
end;
ACol2 := ACol1;
while (cell <> nil) and (cbEast in cell^.MergedNeighbors) do begin
inc(ACol2);
cell := FindCell(ARow2, ACol2);
end;
if cell = nil then begin
Result := false;
exit;
end;
Result := true;
end;
{@@
Clears the list of cells and releases their memory.
}

19
components/fpspreadsheet/fpspreadsheetgrid.pas
View File

@ -188,6 +188,9 @@ type
AOverwriteExisting: Boolean = true); overload;
procedure SelectSheetByIndex(AIndex: Integer);
procedure MergeCells;
procedure UnmergeCells;
{ Utilities related to Workbooks }
procedure Convert_sFont_to_Font(sFont: TsFont; AFont: TFont);
procedure Convert_Font_to_sFont(AFont: TFont; sFont: TsFont);
@ -3147,6 +3150,22 @@ begin
end;
end;
{@@
Merges the selected cells to a single large cell
}
procedure TsCustomWorksheetGrid.MergeCells;
begin
FWorksheet.MergeCells(Selection.Top, Selection.Left, Selection.Bottom, Selection.Right);
end;
{@@
Merges the selected cells to a single large cell
}
procedure TsCustomWorksheetGrid.UnmergeCells;
begin
FWorksheet.UnmergeCells(Selection.Top, Selection.Left, Selection.Bottom, Selection.Right);
end;
{@@
Creates a new empty workbook with the specified number of columns and rows.