paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-10-28 11:31:43 +01:00
Code Issues Packages Projects Releases Wiki Activity

examples: Add example for merging cells in TStringGrid

Browse Source 
git-svn-id: trunk@53068 -
This commit is contained in:
wp 2016-10-04 12:59:53 +00:00
parent d733dec6c7
commit 2b86c05fc8
7 changed files with 534 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitattributes vendored
View File

@ -5438,6 +5438,12 @@ examples/gridexamples/gridcelleditor/gridcelleditor.lpi svneol=native#text/plain
examples/gridexamples/gridcelleditor/gridcelleditor.lpr svneol=native#text/plain examples/gridexamples/gridcelleditor/gridcelleditor.lpr svneol=native#text/plain
examples/gridexamples/gridcelleditor/unit1.lfm svneol=native#text/plain examples/gridexamples/gridcelleditor/unit1.lfm svneol=native#text/plain
examples/gridexamples/gridcelleditor/unit1.pas svneol=native#text/plain examples/gridexamples/gridcelleditor/unit1.pas svneol=native#text/plain
examples/gridexamples/merged_cells/mainform.lfm svneol=native#text/plain
examples/gridexamples/merged_cells/mainform.pas svneol=native#text/plain
examples/gridexamples/merged_cells/mcgrid.pas svneol=native#text/plain
examples/gridexamples/merged_cells/mergedcells_project.lpi svneol=native#text/plain
examples/gridexamples/merged_cells/mergedcells_project.lpr svneol=native#text/plain
examples/gridexamples/merged_cells/readme.txt svneol=native#text/plain
examples/gridexamples/spreadsheet/main.lfm svneol=native#text/plain examples/gridexamples/spreadsheet/main.lfm svneol=native#text/plain
examples/gridexamples/spreadsheet/main.pas svneol=native#text/pascal examples/gridexamples/spreadsheet/main.pas svneol=native#text/pascal
examples/gridexamples/spreadsheet/spreadsheet.ico -text examples/gridexamples/spreadsheet/spreadsheet.ico -text

48
examples/gridexamples/merged_cells/mainform.lfm Normal file
View File

@ -0,0 +1,48 @@
object Form1: TForm1
Left = 289
Height = 452
Top = 174
Width = 650
Caption = 'Form1'
OnCreate = FormCreate
LCLVersion = '1.7'
object ImageList1: TImageList
left = 58
top = 45
Bitmap = {
4C69010000001000000010000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FC00FFFFF700806D5EFF7C614CFF7C614CFF806D5EFFFFFFF700FFFFFC00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FB00FFFFF2007C614CFFE8CDB8FFE8CDB8FF7C614CFFFFFFF200FFFFFA00FFFF
FF00FFFFFE00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFC00FFFFFB00FFFF
F500FFFFED00836248FFEACEB6FFEACEB6FF836248FFFFFFEB00FFFFF500FFFF
F900FFFFFC00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFF700FFFFF200FFFF
EB00FFFFE6008A6245FFECCEB5FFECCEB5FF8A6245FFFFFFE600FFFFEB00FFFF
F100FFFFF700FFFFFF00FFFFFF00FFFFFF00FFFFFF00806D5EFF7A624CFF8362
48FF8A6343FF8A6343FFEDCFB4FFEDCFB4FF8C6343FF8C6342FF856346FF7F63
4BFF816F5EFFFFFFFF00FFFFFF00FFFFFF00FFFFFF007C614CFFEED4BCFFEFD2
B7FFF2D2B5FFF1CFB2FFEDCFB2FFEFCFB2FFF5CFB1FFF4CEB0FFEFCDB0FFEBCD
B2FF7F634BFFFFFFFF00FFFFFF00FFFFFF00FFFFFF007C614CFFE6CCB4FFD3B5
9CFFD4B497FFD5B395FFD4B294FFCFAC8BFFCFA989FFCCA688FFC6A487FFDCBE
A3FF7E614CFFFFFFFF00FFFFFF00FFFFFF00FFFFFF00806D5EFF7C614DFF8362
48FF8A6343FF8E6342FFD2AC8AFFD4AB8AFF906341FF8E6342FF876246FF7E62
4AFF826D5EFFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFF800FFFFF200FFFF
ED00FFFFE6008E6342FFF6D0AEFFD2AC8AFF8E6342FFFFFFE600FFFFED00FFFF
F200FFFFF700FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFC00FFFFFB00FFFF
F500FFFFED00856346FFEFCFB2FFCBAB8EFF856346FFFFFFEB00FFFFF500FFFF
FB00FFFFFC00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FB00FFFFF2007C614CFFECCEB5FFECCEB5FF7C614CFFFFFFF200FFFFFB00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FC00FFFFF700806D5EFF7B604BFF7D624DFF806D5EFFFFFFF700FFFFFC00FDFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
FF00FFFFFF00FFFFFF00FFFFFF00
}
end
end

159
examples/gridexamples/merged_cells/mainform.pas Normal file
View File

@ -0,0 +1,159 @@
unit mainform;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
Grids, mcGrid;
type
{ TForm1 }
TForm1 = class(TForm)
ImageList1: TImageList;
procedure FormCreate(Sender: TObject);
private
Grid: TMCStringGrid;
procedure DrawCellTextHandler(Sender: TObject; ACol, ARow: Integer;
ARect: TRect; AState: TGridDrawState; AText: String; var Handled: Boolean);
procedure MergeCellsHandler(Sender: TObject; ACol, ARow: Integer;
var ALeft, ATop, ARight, ABottom: Integer);
public
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
// Create an instance of TStringGridEx at runtime for testing
Grid := TMCStringGrid.Create(Self);
Grid.Parent := self;
Grid.Align := alClient;
Grid.RowCount := 20;
Grid.ColCount := 10;
Grid.Cells[1, 0] := 'Merged';
Grid.Cells[3, 0] := 'Single';
Grid.Cells[1, 1] := 'combined';
Grid.Cells[3, 1] := 'abc';
Grid.Cells[4, 1] := 'bold';
Grid.Cells[5, 1] := 'Image';
Grid.Cells[2, 3] := 'This is a long text' + LineEnding + 'with line break.';
Grid.Cells[0, 2] := 'Vertical text';
Grid.Cells[0, 6] := 'Centered';
Grid.OnDrawCellText := @DrawCellTextHandler;
Grid.OnMergeCells := @MergeCellsHandler;
Grid.Options := Grid.Options + [goColSpanning, goEditing, goDrawFocusSelected];
if Grid.DefaultRowHeight < ImageList1.Height + 4 then
Grid.DefaultRowHeight := ImageList1.Height + 4
end;
{ This event handler takes care of painting the cell text. Normally it is not
needed for merged cells, but it implements here vertical text direction,
line breaks etc. }
procedure TForm1.DrawCellTextHandler(Sender: TObject; ACol, ARow: Integer;
ARect: TRect; AState: TGridDrawState; AText: String; var Handled: Boolean);
var
ts: TTextStyle;
x, y: Integer;
bmp: TBitmap;
begin
Handled := True;
if (ACol in [2..4]) and (ARow in [3..5]) then
begin
// Word-wrapped text
ts := Grid.Canvas.TextStyle;
ts.SingleLine := false;
ts.Wordbreak := true;
x := ARect.Left + constCellPadding;
y := ARect.Top + constCellPadding;
Grid.Canvas.TextRect(ARect, x, y, AText, ts);
end else
if (ACol = 0) and (ARow in [2..5]) then
begin
// Vertical text
Grid.Canvas.Font.Orientation := 900;
x := (ARect.Left + ARect.Right - Grid.Canvas.TextHeight('Tg')) div 2;
y := ARect.Bottom - constCellPadding;
Grid.Canvas.TextOut(x, y, AText);
Grid.Canvas.Font.Orientation := 0;
end else
if (ACol = 0) and (ARow = 6) then
begin
// Centered text
ts := Grid.Canvas.TextStyle;
ts.Alignment := taCenter;
ts.Layout := tlCenter;
x := (ARect.Left + ARect.Right) div 2;
y := (ARect.Top + ARect.Bottom) div 2;
Grid.Canvas.TextRect(ARect, x, y, AText, ts);
end else
if (ACol = 4) and (ARow = 1) then
begin
// Bold text
Grid.Canvas.Font.Style := [fsBold];
x := ARect.Left + constCellPadding;
y := ARect.Top + constCellPadding;
Grid.Canvas.TextOut(x, y, AText);
Grid.Canvas.Font.Style := [];
end else
if (ACol = 5) and (ARow = 1) then
begin
// Cell with image
bmp := TBitmap.Create;
try
ImageList1.GetBitmap(0, bmp);
x := ARect.Left + constCellPadding;
y := (ARect.Top + ARect.Bottom - bmp.Height) div 2;
Grid.Canvas.Draw(x, y, bmp);
inc(x, bmp.Width + constCellpadding);
y := ARect.Top + constCellPadding;
Grid.Canvas.TextOut(x, y, AText);
finally
bmp.Free;
end;
end else
Handled := false;
end;
{ This is the event handler defining the merged block. In this example we
assume that the cells defined by columns 2..3 and rows 3..5 are will be merged }
procedure TForm1.MergeCellsHandler(Sender: TObject; ACol, ARow: Integer;
var ALeft, ATop, ARight, ABottom: Integer);
begin
// Define a merged block which is a single row heigh
if (ACol in [1..2]) and (ARow = 1) then begin
ALeft := 1;
ARight := 2;
end else
// Define a merged block covering several columns and rows (for the word-wrap text)
if (ACol in [2..3]) and (ARow in [3..5]) then begin
ALeft := 2;
ARight := 3;
Atop := 3;
ABottom := 5;
end;
// Define a merged block in the column headers
if (ACol in [1..2]) and (ARow = 0) then begin
ALeft := 1;
ARight := 2;
end else
// Define a merged block in the row headers (for the vertical text)
if (ACol = 0) and (ARow in [2..5]) then begin
ATop := 2;
ABottom := 5;
end;
end;
end.

205
examples/gridexamples/merged_cells/mcgrid.pas Normal file
View File

@ -0,0 +1,205 @@
unit mcgrid;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Grids;
type
TDrawCellTextEvent = procedure (Sender: TObject; ACol, ARow: Integer;
ARect: TRect; AState: TGridDrawState; AText: String;
var Handled: Boolean) of object;
TMergeCellsEvent = procedure (Sender: TObject; ACol, ARow: Integer;
var ALeft, ATop, ARight, ABottom: Integer) of object;
{ TMCStringGrid: MC = "merged cells" }
TMCStringGrid = class(TStringGrid)
private
FOnMergeCells: TMergeCellsEvent;
FOnDrawCellText: TDrawCellTextEvent;
protected
procedure CalcCellExtent(ACol, ARow: Integer; var ARect: TRect); override;
procedure DoEditorShow; override;
procedure DrawAllRows; override;
procedure DrawCellText(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState; AText: String); override;
procedure DrawFocusRect(ACol, ARow:Integer; ARect:TRect); override;
function GetCells(ACol, ARow: Integer): String; override;
function GetEditText(ACol, ARow: Integer): String; override;
function IsMerged(ACol, ARow: Integer): Boolean; overload;
function IsMerged(ACol, ARow: Integer;
out ALeft, ATop, ARight, ABottom: Integer): Boolean; overload;
procedure MoveSelection; override;
procedure PrepareCanvas(aCol, aRow: Integer; AState: TGridDrawState); override;
procedure SetEditText(ACol, ARow: LongInt; const Value: String); override;
published
property OnDrawCelLText: TDrawCellTextEvent read FOnDrawCellText write FOnDrawCellText;
property OnMergeCells: TMergeCellsEvent read FOnMergeCells write FOnMergeCells;
end;
implementation
{ Calculates the size of the merged block }
procedure TMCStringGrid.CalcCellExtent(ACol, ARow: Integer; var ARect: TRect);
var
L, T, R, B: Integer;
begin
if IsMerged(ACol, ARow, L, T, R, B) then begin
ARect.TopLeft := CellRect(L, T).TopLeft;
ARect.BottomRight := CellRect(R, B).BottomRight;
end;
// Call the inherited procedure to handle non-merged cells
inherited;
end;
{ Make sure that the cell editor of a merged block is the same size as the
merged block }
procedure TMCStringGrid.DoEditorShow;
var
R: TRect;
begin
inherited;
if goColSpanning in Options then begin
CalcCellExtent(Col, Row, R);
Editor.SetBounds(R.Left, R.Top, R.Right-R.Left-1, R.Bottom-R.Top-1);
end;
end;
{ Redraws the FocusRect after all cells have been painted. Otherwise the
FocusRect might not be complete }
procedure TMCStringGrid.DrawAllRows;
var
L, T, R, B: Integer;
rct: TRect;
begin
inherited;
if FocusRectVisible and IsMerged(Col, Row, L, T, R, B) then begin
rct.TopLeft := CellRect(L, T).TopLeft;
rct.BottomRight := CellRect(R, B).BottomRight;
DrawFocusRect(L, T, rct);
end;
end;
{ Draws the cell text. Allows to hook in an external painting routine which
will replace the built-in painting routine if it sets "Handled" to true. }
procedure TMCStringGrid.DrawCellText(ACol, ARow: Integer; ARect: TRect;
AState: TGridDrawState; AText: String);
var
handled: Boolean;
begin
handled := false;
if Assigned(FOnDrawCellText) then
FOnDrawCellText(Self, ACol, ARow, ARect, AState, AText, handled);
if not handled then
inherited;
end;
{ makes sure that the focus rect is drawn to enclose all cells of a
merged block }
procedure TMCStringGrid.DrawFocusRect(ACol, ARow: Integer; ARect: TRect);
begin
CalcCellExtent(ACol, ARow, ARect);
inherited DrawFocusRect(ACol, ARow, ARect);
end;
{ Returns the string to be displayed in the specified cell. In case of a merged
block only the text assigned to the top-left cell of the block is used. }
function TMCStringGrid.GetCells(ACol, ARow: Integer): String;
var
L, T, R, B: Integer;
begin
if IsMerged(ACol, ARow, L, T, R, B) then
Result := inherited GetCells(L, T)
else
Result := inherited GetCells(ACol, ARow);
end;
{ Make sure to use only the topleft cell of a merged block for editing }
function TMCStringGrid.GetEditText(ACol, ARow: Integer): String;
begin
Result := GetCells(ACol, ARow);
if Assigned(OnGetEditText) then OnGetEditText(self, ACol, ARow, Result);
end;
{ Check whether the specified cell belongs to a merged block}
function TMCStringGrid.IsMerged(ACol, ARow: Integer): Boolean;
var
L, T, R, B: Integer;
begin
Result := IsMerged(ACol, ARow, L, T, R, B);
end;
{ Checks whether the specified cell belongs to a merged block and returns the
cell coordinate of the block extent }
function TMCStringGrid.IsMerged(ACol,ARow: Integer;
out ALeft, ATop, ARight, ABottom: Integer): Boolean;
var
tmp: Integer;
begin
Result := false;
if not (goColSpanning in Options) then exit;
if not Assigned(FOnMergeCells) then exit;
ALeft := ACol;
ARight := ACol;
ATop := ARow;
ABottom := ARow;
FOnMergeCells(Self, ACol, ARow, ALeft, ATop, ARight, ABottom);
if ALeft > ARight then begin
tmp := ALeft;
ALeft := ARight;
ARight := tmp;
end;
if ATop > ABottom then begin
tmp := ATop;
ATop := ABottom;
ABottom := tmp;
end;
Result := (ALeft <> ARight) or (ATop <> ABottom);
end;
{ Repaints the entire grid after the selection is moved because normally only
the selected cell would be painted, and this would result in an imcompletely
painted merged block }
procedure TMCStringGrid.MoveSelection;
begin
inherited;
InvalidateGrid;
end;
{ Makes sure that all cells of the merged block are drawn as selected/focused,
not just the active cell }
procedure TMCStringGrid.PrepareCanvas(aCol, aRow: Integer;
AState: TGridDrawState);
var
L, T, R, B: Integer;
begin
if IsMerged(ACol, ARow, L, T, R, B) and
(Col >= L) and (Col <= R) and (Row >= T) and (Row <= B) and
not ((ACol = Col) and (ARow = Row))
then
AState := AState + [gdSelected, gdFocused];
inherited;
end;
{ Writes the edited text back into the grid. Makes sure that, in case of a
merged block, the edited text is assigned to the top/left cell }
procedure TMCStringGrid.SetEditText(ACol, ARow: LongInt; const Value: String);
var
L, T, R, B: Integer;
begin
if IsMerged(ACol, ARow, L,T,R,B) then
inherited SetEditText(L, T, Value)
else
inherited SetEditText(ACol, ARow, Value);
end;
end.

79
examples/gridexamples/merged_cells/mergedcells_project.lpi Normal file
View File

@ -0,0 +1,79 @@
<?xml version="1.0" encoding="UTF-8"?>
<CONFIG>
<ProjectOptions>
<Version Value="9"/>
<PathDelim Value="\"/>
<General>
<SessionStorage Value="InProjectDir"/>
<MainUnit Value="0"/>
<Title Value="mergedcells_project"/>
<ResourceType Value="res"/>
<UseXPManifest Value="True"/>
<Icon Value="0"/>
</General>
<BuildModes Count="1">
<Item1 Name="Default" Default="True"/>
</BuildModes>
<PublishOptions>
<Version Value="2"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
</local>
</RunParams>
<RequiredPackages Count="1">
<Item1>
<PackageName Value="LCL"/>
</Item1>
</RequiredPackages>
<Units Count="3">
<Unit0>
<Filename Value="mergedcells_project.lpr"/>
<IsPartOfProject Value="True"/>
</Unit0>
<Unit1>
<Filename Value="mainform.pas"/>
<IsPartOfProject Value="True"/>
<ComponentName Value="Form1"/>
<HasResources Value="True"/>
<ResourceBaseClass Value="Form"/>
</Unit1>
<Unit2>
<Filename Value="mcgrid.pas"/>
<IsPartOfProject Value="True"/>
</Unit2>
</Units>
</ProjectOptions>
<CompilerOptions>
<Version Value="11"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="mergedcells_project"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
</Options>
</Linking>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

21
examples/gridexamples/merged_cells/mergedcells_project.lpr Normal file
View File

@ -0,0 +1,21 @@
program mergedcells_project;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}{$IFDEF UseCThreads}
cthreads,
{$ENDIF}{$ENDIF}
Interfaces, // this includes the LCL widgetset
Forms, mainform, mcgrid
{ you can add units after this };
{$R *.res}
begin
RequireDerivedFormResource := True;
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.

16
examples/gridexamples/merged_cells/readme.txt Normal file
View File

@ -0,0 +1,16 @@
--------------------------------------------------------------------------------
merged_cells
--------------------------------------------------------------------------------
In this sample project you'll find a derived stringgrid which allows to combine
adjacent cells to a larger block ("merge") easily.
For this purpose you must
- add goColSpanning to the grid's Options
- write an event handler for OnMergeCells to define the range of cells to be
merged - see the demo project.
In addition, this enhanced grid implements another event handler, OnDrawCellText,
which allows to hook into the text painting process for each cell. This way it
is relatively easy to draw word-wrapped text, vertical text,
centered/right-aligned text, etc - again, see the demo project.