unit MyStringGrid;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Graphics, 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;
TMyStringGrid = class(TStringGrid)
private
fLeftColWidth : Integer;
fMergeLock : Integer;
fOnMergeCells : TMergeCellsEvent;
fOnDrawCellText : TDrawCellTextEvent;
procedure SetLeftColWidth(aValue : Integer);
protected
procedure CalcCellExtent(aCol, aRow : Integer; var aRect : TRect); override;
procedure DoEditorShow; override;
procedure DrawCell(aCol, aRow : Integer; aRect : TRect; aState : TGridDrawState); override;
procedure DrawCellText(aCol, aRow : Integer; aRect : TRect;
aState : TGridDrawState; aText : String); 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;
function MoveNextSelectable(Relative : Boolean; dCol, dRow : Integer) : Boolean; override;
public
procedure Invalidate; override;
constructor Create(AOwner : TComponent); override;
published
property LeftColWidth : Integer read fLeftColWidth write SetLeftColWidth;
property OnDrawCelLText : TDrawCellTextEvent read fOnDrawCellText write fOnDrawCellText;
property OnMergeCells : TMergeCellsEvent read fOnMergeCells write fOnMergeCells;
end;
procedure Register;
implementation
{$R mystringgrid.res}
constructor TMyStringGrid.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
AlternateColor := clMoneyGreen;
Color := clCream;
fLeftColWidth := 20;
ColWidths[0] := fLeftColWidth;
RowCount := 5;
ColCount := 3;
AutoFillColumns := True;
end;
procedure TMyStringGrid.Invalidate;
begin
inherited;
end;
procedure TMyStringGrid.SetLeftColWidth(aValue : Integer);
begin
if fLeftColWidth <> aValue then
begin
fLeftColWidth := aValue;
ColWidths[0] := fLeftColWidth;
end;
Invalidate;
end;
{ Calculates the size of the merged block }
procedure TMyStringGrid.CalcCellExtent(aCol, aRow : Integer; var aRect: TRect);
var
L, T, R, B, dummy: Integer;
begin
if IsMerged(aCol, aRow, L, T, R, B) then
begin
ColRowToOffset(True, True, L, aRect.Left, dummy);
ColRowToOffset(True, True, R, dummy, aRect.Right);
ColRowToOffset(False, True, T, aRect.Top, dummy);
ColRowToOffset(False, True, B, dummy, aRect.Bottom);
end
else
// 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 TMyStringGrid.DoEditorShow;
var
R : TRect;
begin
inherited;
if (goColSpanning in Options) and Assigned(Editor) then
begin
R := CellRect(Col, Row);
CalcCellExtent(Col, Row, R);
Editor.SetBounds(R.Left, R.Top, R.Right - R.Left - 1, R.Bottom - R.Top - 1);
end;
end;
procedure TMyStringGrid.DrawCell(aCol, aRow : Integer; aRect : TRect;
aState : TGridDrawState);
var
L, T, R, B : Integer;
begin
if IsMerged(aCol, aRow, L, T, R, B) and ((aCol <> L) or (aRow <> T)) then
// nothing to draw
else
inherited DrawCell(aCol, aRow, aRect, aState);
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 TMyStringGrid.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;
{ 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 TMyStringGrid.GetCells(aCol, aRow: Integer) : String;
var
L, T, R, B: Integer;
begin
if (fMergeLock = 0) and 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 TMyStringGrid.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 TMyStringGrid.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 TMyStringGrid.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;
inc(fMergeLock);
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);
dec(fMergeLock);
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 TMyStringGrid.MoveSelection;
begin
if SelectActive then
InvalidateGrid;
inherited;
end;
{ Makes sure that all cells of the merged block are drawn as selected/focused,
not just the active cell }
procedure TMyStringGrid.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;
if aCol = 0 then
begin
Canvas.Font.Color := clPurple;
Canvas.Font.Style := [fsBold];
end;
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 TMyStringGrid.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;
function TMyStringGrid.MoveNextSelectable(Relative : Boolean; dCol, dRow : Integer
): Boolean;
var
L, T, R, B: Integer;
begin
if Relative and IsMerged(Col, Row, L, T, R, B) then
begin
// we are only interested on relative movement (basically by keyboard)
if dCol > 0 then dCol := R - Col + 1 else
if dCol < 0 then dCol := L - Col - 1 else
if dRow > 0 then dRow := B - Row + 1 else
if dRow < 0 then dRow := T - Row - 1;
end;
Result := inherited MoveNextSelectable(Relative, dCol, dRow);
end;
procedure Register;
begin
RegisterComponents('Misc',[TMyStringGrid]);
end;
end.