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

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

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;

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.
 }

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.