From e277e0985034bce89cad3984b29fbce8fa39c58b Mon Sep 17 00:00:00 2001 From: wp_xxyyzz Date: Tue, 9 Sep 2014 15:51:56 +0000 Subject: [PATCH] fpspreadsheet: Beginning with infrastructure for merging of cells git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@3534 8e941d3f-bd1b-0410-a28a-d453659cc2b4 --- .../examples/spready/mainform.lfm | 26 ++- .../examples/spready/mainform.pas | 25 ++ components/fpspreadsheet/fpspreadsheet.pas | 220 +++++++++++++++++- .../fpspreadsheet/fpspreadsheetgrid.pas | 19 ++ 4 files changed, 287 insertions(+), 3 deletions(-) diff --git a/components/fpspreadsheet/examples/spready/mainform.lfm b/components/fpspreadsheet/examples/spready/mainform.lfm index cb1685db8..60299ad9d 100644 --- a/components/fpspreadsheet/examples/spready/mainform.lfm +++ b/components/fpspreadsheet/examples/spready/mainform.lfm @@ -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 diff --git a/components/fpspreadsheet/examples/spready/mainform.pas b/components/fpspreadsheet/examples/spready/mainform.pas index 26bdddb4d..e58fac733 100644 --- a/components/fpspreadsheet/examples/spready/mainform.pas +++ b/components/fpspreadsheet/examples/spready/mainform.pas @@ -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; diff --git a/components/fpspreadsheet/fpspreadsheet.pas b/components/fpspreadsheet/fpspreadsheet.pas index 1e9ff588b..716708575 100755 --- a/components/fpspreadsheet/fpspreadsheet.pas +++ b/components/fpspreadsheet/fpspreadsheet.pas @@ -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. } diff --git a/components/fpspreadsheet/fpspreadsheetgrid.pas b/components/fpspreadsheet/fpspreadsheetgrid.pas index 142dec12c..db1a017c9 100644 --- a/components/fpspreadsheet/fpspreadsheetgrid.pas +++ b/components/fpspreadsheet/fpspreadsheetgrid.pas @@ -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.