unit mycustomgrid;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, StdCtrls, Controls, Forms, Graphics, fgl, ExtCtrls,
LCLType, math, LCLIntf;
const
MYCELLNAME = 'MyCell';
MIN_COL_WIDTH = 10;
DEFAULT_COLUMN_SIZE = 100;
ROWCOUNT = 6;
COLCOUNT = 7;
type
{ TMyGridColumn }
TMyGridColumn = class(TObject)
private
FWidth: Integer;
procedure SetWidth(AValue: Integer);
public
constructor Create; overload;
destructor Destroy; override;
property Width: Integer read FWidth write SetWidth;
end;
TMyGridColumns = specialize TFPGObjectList<TMyGridColumn>;
{ TCustomMyCell }
TCustomMyCell = class(TCustomControl)
private
_lblFooter: TLabel;
_lblHeader: TLabel;
_myviewer: TPanel;
function GetFooter: string;
function GetHeader: string;
procedure SetFooter(AValue: string);
procedure SetHeader(AValue: string);
// events
procedure MouseDownCell(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseMoveCell(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure MouseUpCell(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Footer: string read GetFooter write SetFooter;
property Header: string read GetHeader write SetHeader;
end;
TMyCell = class(TCustomMyCell)
end;
TMyCellList = specialize TFPGObjectList<TMyCell>;
{ TMyCustomGrid }
TMyCustomGrid = class(TCustomControl)
private
FGridLineColor: TColor;
FGridLineStyle: TPenStyle;
FGridLineWidth: Integer;
_columns: TMyGridColumns;
_mycells: TMyCellList;
_oldCursorPos: TPoint;
_resizingcolumnID: Integer;
procedure DrawMyCellGrid(aCol, aRow: Integer);
procedure setcellposition(const aCol, aVisibleRow: Integer; mycell: TMyCell);
procedure getcellpositionstd(const aCol, aVisibleRow: Integer; out aTop, aLeft, aHeight, aWidth: Integer);
procedure getcellposition(const aCol, aVisibleRow: Integer; out aTop, aLeft, aHeight, aWidth: Integer);
function getgridclientwidth: Integer;
function getgridclientheight: Integer;
procedure updatecolumns(const newlength: Integer);
function CreateMyCell(aCol, aRow: Integer): TMyCell;
procedure DrawAllRows;
procedure DrawRow(aRow: Integer);
procedure DestroyMyCells;
procedure CreateMyCells;
function IsOverColumnLine(const X: Integer): Integer;
procedure SetAllCellPosition;
procedure SetGridLineColor(AValue: TColor);
procedure SetGridLineStyle(AValue: TPenStyle);
procedure SetGridLineWidth(AValue: Integer);
function TotalGridWidth: Integer;
procedure MouseDownMyGrid(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseUpMyGrid(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MouseMoveMyGrid(Sender: TObject; Shift: TShiftState; X, Y: Integer);
protected
{ Protected declarations }
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property GridLineColor: TColor read FGridLineColor write SetGridLineColor default clSilver;
property GridLineStyle: TPenStyle read FGridLineStyle write SetGridLineStyle;
property GridLineWidth: Integer read FGridLineWidth write SetGridLineWidth default 1;
end;
TMyGrid = class(TMyCustomGrid)
published
end;
implementation
{ TMyGridColumn }
procedure TMyGridColumn.SetWidth(AValue: Integer);
begin
if FWidth=AValue then Exit;
FWidth:=AValue;
end;
constructor TMyGridColumn.Create;
begin
end;
destructor TMyGridColumn.Destroy;
begin
inherited Destroy;
end;
{ TCustomMyCell }
procedure TCustomMyCell.SetFooter(AValue: string);
begin
_lblFooter.Caption:= AValue;
end;
function TCustomMyCell.GetFooter: string;
begin
Result:= _lblFooter.Caption;
end;
function TCustomMyCell.GetHeader: string;
begin
Result:= _lblHeader.Caption;
end;
procedure TCustomMyCell.SetHeader(AValue: string);
begin
_lblHeader.Caption:= AValue;
end;
procedure TCustomMyCell.MouseDownCell(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
TMyGrid(Self.Parent).OnMouseDown(Self, Button, Shift, X, Y);
end;
procedure TCustomMyCell.MouseMoveCell(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
TMyGrid(Self.Parent).OnMouseMove(Self, Shift, X, Y);
end;
procedure TCustomMyCell.MouseUpCell(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
TMyGrid(Self.Parent).OnMouseUp(Self, Button, Shift, X, Y);
end;
constructor TCustomMyCell.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
// _lblFooter
_lblFooter:= TLabel.Create(Self);
_lblFooter.Align:= alBottom;
_lblFooter.AutoSize:= True;
_lblFooter.OnMouseDown:= @MouseDownCell;
_lblFooter.OnMouseMove:= @MouseMoveCell;
_lblFooter.OnMouseUp:= @MouseUpCell;
_lblFooter.Parent:= Self;
// _lblHeader
_lblHeader:= TLabel.Create(Self);
_lblHeader.Align:= alTop;
_lblHeader.AutoSize:= True;
_lblHeader.OnMouseDown:= @MouseDownCell;
_lblHeader.OnMouseMove:= @MouseMoveCell;
_lblHeader.OnMouseUp:= @MouseUpCell;
_lblHeader.Parent:= Self;
// _myviewer
_myviewer:= TPanel.Create(Self);
_myviewer.Align:= alClient;
_myviewer.AutoSize:= True;
_myviewer.OnMouseDown:= @MouseDownCell;
_myviewer.OnMouseMove:= @MouseMoveCell;
_myviewer.OnMouseUp:= @MouseUpCell;
_myviewer.Parent:= Self;
OnMouseDown:= @MouseDownCell;
OnMouseMove:= @MouseMoveCell;
OnMouseUp:= @MouseUpCell;
end;
destructor TCustomMyCell.Destroy;
begin
inherited Destroy;
end;
{ TMyCustomGrid }
procedure TMyCustomGrid.CreateMyCells;
var
i, j: Integer;
mycell: TMyCell;
begin
for j:= 0 to RowCount - 1 do begin
for i:= 0 to ColCount - 1 do begin
mycell:= CreateMyCell(i, j);
_mycells.Add(mycell);
end;
end;
end;
function TMyCustomGrid.IsOverColumnLine(const X: Integer): Integer;
var
i, colidx, collineleft, margin: Integer;
begin
colidx:= -1;
margin:= 2;
collineleft:= 0;
for i:= 0 to _columns.Count - 1 do begin
collineleft:= collineleft + GridLineWidth + _columns[i].Width;
if (X >= (collineleft - margin)) and (X <= (collineleft + margin)) then begin
colidx:= i;
Break;
end;
end;
Result:= colidx
end;
procedure TMyCustomGrid.MouseDownMyGrid(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
cellIdx: Integer;
begin
_resizingcolumnID:= IsOverColumnLine(X);
if _resizingcolumnID >= 0 then begin
Screen.Cursor:= crHSplit;
GetCursorPos(_oldCursorPos);
end;
end;
procedure TMyCustomGrid.MouseUpMyGrid(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
_resizingcolumnID:= -1;
end;
procedure TMyCustomGrid.MouseMoveMyGrid(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
newWidth: Integer;
newPos: TPoint;
begin
if IsOverColumnLine(X) >= 0 then
Screen.Cursor:= crHSplit
else
Screen.Cursor:= crDefault;
// resize column
if _resizingcolumnID >= 0 then
begin
GetCursorPos(newPos);
newWidth:= _columns[_resizingcolumnID].Width + newPos.x - _oldCursorPos.x;
_oldCursorPos:= newPos;
if newWidth > MIN_COL_WIDTH then begin
_columns[_resizingcolumnID].Width:= newWidth;
Invalidate;
end;
end;
end;
procedure TMyCustomGrid.SetAllCellPosition;
var
i, j: Integer;
mycell: TMyCell;
begin
for j:= 0 to RowCount - 1 do begin
for i:= 0 to ColCount - 1 do begin
mycell:= _mycells[j * ColCount + i];
setcellposition(i, j, mycell);
end;
end;
end;
procedure TMyCustomGrid.SetGridLineColor(AValue: TColor);
begin
if FGridLineColor=AValue then Exit;
FGridLineColor:=AValue;
Invalidate;
end;
procedure TMyCustomGrid.SetGridLineStyle(AValue: TPenStyle);
begin
if FGridLineStyle=AValue then Exit;
FGridLineStyle:=AValue;
Invalidate;
end;
procedure TMyCustomGrid.SetGridLineWidth(AValue: Integer);
begin
if FGridLineWidth=AValue then Exit;
FGridLineWidth:=AValue;
Invalidate;
end;
procedure TMyCustomGrid.setcellposition(const aCol, aVisibleRow: Integer;
mycell: TMyCell);
var
aTop, aLeft, aHeight, aWidth: Integer;
begin
getcellposition(aCol, aVisibleRow, aTop, aLeft, aHeight, aWidth);
with mycell do begin
Top:= aTop;
Left:= aLeft;
Height:= aHeight;
Width:= aWidth;
end;
end;
procedure TMyCustomGrid.getcellpositionstd(const aCol,
aVisibleRow: Integer; out aTop, aLeft, aHeight, aWidth: Integer);
var
i, cheight, leftOffset: Integer;
begin
aWidth:= _columns[aCol].Width;
// calculates Left offset (due to horizontal scrollbar position)
leftOffset:= 0;
// calculates left
aLeft:= GridLineWidth;
for i:= 0 to aCol - 1 do
aLeft:= aLeft + _columns[i].Width + GridLineWidth;
aLeft:= aLeft - leftOffset;
// calculates cell height
cheight:= getgridclientheight;
aHeight:= cheight div RowCount;
// calculates Top
aTop:= aVisibleRow * aHeight + ((aVisibleRow + 1) * GridLineWidth);
end;
procedure TMyCustomGrid.getcellposition(const aCol, aVisibleRow: Integer; out
aTop, aLeft, aHeight, aWidth: Integer);
begin
getcellpositionstd(aCol, aVisibleRow, aTop, aLeft, aHeight, aWidth);
end;
function TMyCustomGrid.getgridclientwidth: Integer;
var
cwidth: Integer;
begin
cwidth:= Self.ClientWidth;
// subtract grid lines width
Result:= cwidth - (ColCount + 1) * GridLineWidth;
end;
function TMyCustomGrid.getgridclientheight: Integer;
var
cheight: Integer;
begin
cheight:= ClientHeight;
// subtract grid lines width
Result:= cheight - (RowCount + 1) * GridLineWidth;
end;
procedure TMyCustomGrid.updatecolumns(const newlength: Integer);
var
newcol: TMyGridColumn;
i, prevcolcount: Integer;
begin
prevcolcount:= _columns.Count;
if newlength > prevcolcount then begin
for i:= prevcolcount + 1 to newlength do begin
newcol:= TMyGridColumn.Create;
newcol.Width:= DEFAULT_COLUMN_SIZE;
_columns.Add(newcol);
end;
end;
if newlength < prevcolcount then begin
for i:= prevcolcount - 1 downto newlength do
_columns.Delete(i);
end;
end;
function TMyCustomGrid.CreateMyCell(aCol, aRow: Integer
): TMyCell;
var
mycell: TMyCell;
begin
mycell:= TMyCell.Create(Self);
mycell.Name:= format('%s%d', [MYCELLNAME, _mycells.Count + 1]);
mycell.Parent:= Self;
Result:= mycell;
end;
procedure TMyCustomGrid.DrawAllRows;
var
i: Integer;
begin
for i:= 0 to RowCount - 1 do begin
DrawRow(i);
end;
end;
procedure TMyCustomGrid.DrawMyCellGrid(aCol, aRow: Integer);
var
aRect: TRect;
aWidth, aTop, aLeft, aHeight, correction: Integer;
begin
with Canvas do begin
if fGridLineWidth > 0 then begin
getcellposition(aCol, aRow, aTop, aLeft, aHeight, aWidth);
Pen.EndCap:= pecSquare;
Pen.Style := fGridLineStyle;
Pen.Color := FGridLineColor;
Pen.Width := fGridLineWidth;
correction:= 0;
correction:= FGridLineWidth div 2;
if (FGridLineWidth mod 2) <> 0 then
correction:= correction + 1;
aRect.Top:= aTop - correction;
aRect.Bottom:= aRect.Top + aHeight + (correction);
aRect.Left:= aLeft - correction;
aRect.Right:= aRect.Left + aWidth + (correction);
correction:= 0;
if FGridLineWidth > 1 then
correction:= Max(1, (FGridLineWidth div 2));
// draw bottom-aligned line
MoveTo(aRect.Left, aRect.Bottom + correction);
LineTo(aRect.Right + correction, aRect.Bottom + correction);
// draw right-aligned line
MoveTo(aRect.Right + correction, aRect.Top);
LineTo(aRect.Right + correction, aRect.Bottom + correction);
// if is the first visible row draw also the top-aligned line
if (aRow = 0) then begin
MoveTo(aRect.Left, aRect.Top);
LineTo(aRect.Right, aRect.Top);
end;
// if aCol = 0 draw also the left-aligned line
if (aCol = 0) then begin
MoveTo(aRect.Left, aRect.Top);
LineTo(aRect.Left, aRect.Bottom);
end;
end;
end;
end;
procedure TMyCustomGrid.DrawRow(aRow: Integer);
var
i: Integer;
begin
for i:= 0 to ColCount - 1 do begin
DrawMyCellGrid(i, aRow);
end;
end;
procedure TMyCustomGrid.DestroyMyCells;
begin
_mycells.Clear;
end;
function TMyCustomGrid.TotalGridWidth: Integer;
var
i, gwidth: Integer;
begin
gwidth:= GridLineWidth;
for i:= 0 to _columns.Count - 1 do begin
gwidth:= gwidth + _columns[i].Width + GridLineWidth;
end;
Result:= gwidth;
end;
procedure TMyCustomGrid.Paint;
begin
if _mycells.Count = (RowCount * ColCount) then begin
SetAllCellPosition;
DrawAllRows;
end;
inherited Paint;
end;
constructor TMyCustomGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle:= ControlStyle - [csNoFocus];
Color:= clWhite;
BorderStyle:= bsSingle;
OnMouseMove:= @MouseMoveMyGrid;
OnMouseDown:= @MouseDownMyGrid;
OnMouseUp:= @MouseUpMyGrid;
FGridLineColor:=clSilver;
FGridLineStyle:=psSolid;
FGridLineWidth := 1;
_resizingcolumnID:= -1;
_columns:= TMyGridColumns.Create;
updatecolumns(ColCount);
_mycells:= TMyCellList.Create(True);
CreateMyCells;
SetInitialBounds(0, 0, 200, 150);
end;
destructor TMyCustomGrid.Destroy;
begin
if Assigned(_columns) then
_columns.Free;
if Assigned(_mycells) then
_mycells.Free;
inherited Destroy;
end;
end.