paweld/lazarus-ccr
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
e44baffbcc
lazarus-ccr/components/nicegrid/source/nicegrid.pas

4240 lines
104 KiB
ObjectPascal
Raw Blame History

{-------------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/
Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
the specific language governing rights and limitations under the License.
The Original Code is NiceGrid.pas released at April 11st, 2003.
The Original Code is a part of NiceGrid component.
The Initial Developer of the Original Code is Priyatna.
(Website: http://www.priyatna.org/ Email: me@priyatna.org)
All Rights Reserved.
Contributors:
- C. S. Phua <csphua@teledynamics.com.my>
Alternatively, the contents of this file may be used under the terms of the
GNU General Public License Version 2 or later (the "GPL"), in which case
the provisions of the GPL are applicable instead of those above.
If you wish to allow use of your version of this file only under the terms
of the GPL and not to allow others to use your version of this file
under the MPL, indicate your decision by deleting the provisions above and
replace them with the notice and other provisions required by the GPL.
If you do not delete the provisions above, a recipient may use your version
of this file under either the MPL or the GPL.
-------------------------------------------------------------------------------}
unit NiceGrid;
{$IFDEF FPC}
{$MODE Delphi}
{$ENDIF}
interface
uses
{$IFDEF FPC}
LCLIntf, LCLType, LMessages,
{$ELSE}
Windows, Messages,
{$ENDIF}
Forms, Controls, SysUtils, Types, Classes, Graphics, Contnrs,
StdCtrls, ExtCtrls, Clipbrd;
type
PHeaderInfo = ^THeaderInfo;
THeaderInfo = record
Str: string;
Rc: TRect;
end;
THorzAlign = (haLeft, haCenter, haRight);
TVertAlign = (vaTop, vaCenter, vaBottom);
TGutterKind = (gkNone, gkBlank, gkPointer, gkNumber, gkString);
TGridHittest = (gtNone, gtLeftTop, gtLeft, gtTop, gtCell, gtColSizing, gtSmallBox);
TNiceGridState = (gsNormal, gsSelAll, gsSelRow, gsSelCol, gsCell, gsColSize, gsBoxDrag);
TNiceGrid = class;
TNiceColumn = class(TCollectionItem)
private
FTitle: string;
FFooter: string;
FWidth: Integer;
FFont: TFont;
FColor: TColor;
FHorzAlign: THorzAlign;
FVertAlign: TVertAlign;
FVisible: Boolean;
FStrings: TStrings;
FTag: Integer;
FTag2: Integer;
FCanResize: Boolean;
FHint: string;
FReadOnly: Boolean;
function GetGrid: TNiceGrid;
function IsFontStored: Boolean;
procedure FontChange(Sender: TObject);
procedure SetTitle(Value: string);
procedure SetWidth(Value: Integer);
procedure SetFont(Value: TFont);
procedure SetColor(Value: TColor);
procedure SetHorzAlign(Value: THorzAlign);
procedure SetVertAlign(Value: TVertAlign);
procedure SetVisible(Value: Boolean);
procedure SetStrings(Value: TStrings);
procedure SetFooter(const Value: string);
protected
function GetDisplayName: string; override;
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
published
property Grid: TNiceGrid read GetGrid;
property Title: string read FTitle write SetTitle;
property Footer: string read FFooter write SetFooter;
property Width: Integer read FWidth write SetWidth;
property Font: TFont read FFont write SetFont stored IsFontStored;
property Color: TColor read FColor write SetColor default clWindow;
property HorzAlign: THorzAlign read FHorzAlign write SetHorzAlign default haLeft;
property VertAlign: TVertAlign read FVertAlign write SetVertAlign default vaCenter;
property Visible: Boolean read FVisible write SetVisible default True;
property Tag: Integer read FTag write FTag default 0;
property Tag2: Integer read FTag2 write FTag2 default 0;
property Hint: string read FHint write FHint;
property Strings: TStrings read FStrings write SetStrings;
property CanResize: Boolean read FCanResize write FCanResize default True;
property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
end;
TNiceColumns = class(TCollection)
private
FGrid: TNiceGrid;
function GetItem(Index: Integer): TNiceColumn;
procedure SetItem(Index: Integer; Value: TNiceColumn);
protected
function GetOwner: TPersistent; override;
procedure Update(Item: TCollectionItem); override;
public
constructor Create(AGrid: TNiceGrid);
property Grid: TNiceGrid read FGrid;
property Items[Index: Integer]: TNiceColumn read GetItem write SetItem; default;
function Add: TNiceColumn;
function AddItem(Item: TNiceColumn; Index: Integer): TNiceColumn;
function Insert(Index: Integer): TNiceColumn;
end;
TNiceInplace = class(TEdit)
private
FGrid: TNiceGrid;
FAlignment: THorzAlign;
CellX, CellY: Integer;
procedure SetAlignment(Value: THorzAlign);
protected
procedure CreateParams(var Params: TCreateParams); override;
procedure Change; override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
public
constructor Create(Grid: TNiceGrid); reintroduce;
procedure ShowEdit(X, Y: Integer);
procedure HideEdit;
end;
TMergeCell = class(TObject)
public
Caption: string;
Rc: TRect;
Color: TColor;
Font: TFont;
HorzAlign: THorzAlign;
VertAlign: TVertAlign;
constructor Create;
destructor Destroy; override;
end;
TOnDrawCellEvent = procedure (Sender: TObject; ACanvas: TCanvas; X, Y: Integer;
Rc: TRect; var Handled: Boolean) of object;
TOnDrawHeaderEvent = procedure (Sender: TObject; ACanvas: TCanvas; Rc: TRect;
Str: string; var Handled: Boolean) of object;
TOnFilterChar = procedure (Sender: TObject; Col: Integer; Row: Integer;
Chr: Char; var Allowed: Boolean) of object;
TOnHeaderClick = procedure (Sender: TObject; Col: Integer;
Button: TMouseButton; Shift: TShiftState) of object;
TOnGutterClick = procedure (Sender: TObject; Row: Integer;
Button: TMouseButton; Shift: TShiftState) of object;
TOnCellAssignment = procedure (Sender: TObject; Col, Row: Integer;
var Str: string) of object;
TOnCellChange = procedure (Sender: TObject; Col, Row: Integer; var Str: string)
of object;
TOnCellChanging = procedure (Sender: TObject; Col, Row: Integer;
var CanChange: Boolean) of object;
TOnRowEvent = procedure (Sender: TObject; ARow: Integer) of object;
TOnColRowChanged = procedure (Sender: TObject; Col, Row: Integer) of object;
TNiceGridSync = class;
TNiceGrid = class(TCustomPanel)
private
ForcedColumn: Integer;
FixedWidth, FixedHeight: Integer;
BodyWidth, BodyHeight: Integer;
AllWidth, AllHeight: Integer;
FooterTop: Integer;
CellBox: TRect;
FHorzOffset: Integer;
FVertOffset: Integer;
FMaxHScroll: Integer;
FMaxVScroll: Integer;
FSmallChange: Integer;
FLargeChange: Integer;
FAutoAddRow: Boolean;
FRowCount: Integer;
FDefRowHeight: Integer;
FDefColWidth: Integer;
FFlat: Boolean;
FGridState: TNiceGridState;
FHeaderLine: Integer;
FHeaderInfos: TList;
FUpdating: Boolean;
FColor: TColor;
FAlternateColor: TColor;
FGridColor: TColor;
FShowGrid: Boolean;
FHeaderColor: TColor;
FHeaderLightColor: TColor;
FHeaderDarkColor: TColor;
FSelectionColor: TColor;
FHeaderFont: TFont;
FGutterFont: TFont;
FGutterKind: TGutterKind;
FGutterWidth: Integer;
FFitToWidth: Boolean;
FAutoColWidth: Boolean;
FReadOnly: Boolean;
FColumns: TNiceColumns;
ValidationEnabled: Boolean;
FEdit: TNiceInplace;
FCol: Integer;
FRow: Integer;
FCol2, FRow2: Integer; // Selection
FSelectArea: TRect;
SmallBox: TRect;
SmallBoxArea: TRect;
SmallBoxPos: Byte;
BuffString: string;
IsEditing: Boolean;
SizingCol: Integer;
SizingColX: Integer;
LastHover: Integer;
Sync: TNiceGridSync;
Mergeds: TList;
FOnDrawCell: TOnDrawCellEvent;
FOnDrawHeader: TOnDrawHeaderEvent;
FOnDrawGutter: TOnDrawHeaderEvent;
FOnDrawFooter: TOnDrawHeaderEvent;
FOnFilterChar: TOnFilterChar;
FOnHeaderClick: TOnHeaderClick;
FOnGutterClick: TOnGutterClick;
FOnCellChange: TOnCellChange;
FOnCellChanging: TOnCellChanging;
FOnColRowChanged: TOnColRowChanged;
FOnInsertRow: TOnRowEvent;
FOnDeleteRow: TOnRowEvent;
FOnCellAssignment: TOnCellAssignment;
FGutterStrings: TStrings;
FShowFooter: Boolean;
FFooterFont: TFont;
FEnabled: Boolean;
FAutoFillRight: Boolean;
FAutoFillDown: Boolean;
{$IFDEF FPC}
procedure WMUnknown(var Msg: TLMessage); message LM_USER + $B902;
procedure WMVScroll(var Msg: TLMVScroll); message LM_VSCROLL;
procedure WMHScroll(var Msg: TLMHScroll); message LM_HSCROLL;
procedure WMMouseWheel(var Msg: TLMessage{TWMMouseWheel}); message LM_MOUSEWHEEL;
procedure WMSize(var Msg: TLMessage); message LM_SIZE;
procedure WMEraseBkgnd(var Msg: TLMEraseBkGnd); message LM_ERASEBKGND;
procedure WMSetFocus(var Msg: TLMSetFocus); message LM_SETFOCUS;
procedure WMKillFocus(var Msg: TLMKillFocus); message LM_KILLFOCUS;
procedure CMWantSpecialKey(var Message: TLMKey); message CM_WANTSPECIALKEY;
procedure CMFontChanged(var Msg: TLMessage); message CM_FONTCHANGED;
{$ELSE}
procedure WMUnknown(var Msg: TMessage); message WM_USER + $B902;
procedure WMVScroll(var Msg: TWMVScroll); message WM_VSCROLL;
procedure WMHScroll(var Msg: TWMHScroll); message WM_HSCROLL;
procedure WMMouseWheel(var Msg: TWMMouseWheel); message WM_MOUSEWHEEL;
procedure WMSize(var Msg: TMessage); message WM_SIZE;
procedure WMEraseBkgnd(var Msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure WMSetFocus(var Msg: TWMSetFocus); message WM_SETFOCUS;
procedure WMKillFocus(var Msg: TWMKillFocus); message WM_KILLFOCUS;
procedure CMWantSpecialKey(var Message: TWMKey); message CM_WANTSPECIALKEY;
procedure CMFontChanged(var Msg: TMessage); message CM_FONTCHANGED;
{$ENDIF}
function TotalWidth: Integer;
procedure ClearHeaderInfos;
procedure ClearUnused;
procedure RenderGutter;
procedure RenderHeader;
procedure DrawSelection;
procedure SetHorzOffset(Value: Integer);
procedure SetVertOffset(Value: Integer);
function GetColCount: Integer;
procedure SetColCount(Value: Integer);
procedure SetRowCount(Value: Integer);
procedure SetDefColWidth(Value: Integer);
procedure SetDefRowHeight(Value: Integer);
procedure SetFlat(Value: Boolean);
procedure SetColor(Value: TColor); reintroduce;
procedure SetAlternateColor(Value: TColor);
procedure SetGridColor(Value: TColor);
procedure SetShowGrid(Value: Boolean);
procedure SetHeaderLine(Value: Integer);
procedure SetHeaderColor(Value: TColor);
procedure SetHeaderLightColor(Value: TColor);
procedure SetHeaderDarkColor(Value: TColor);
procedure SetHeaderFont(Value: TFont);
procedure SetSelectionColor(Value: TColor);
procedure SetFitToWidth(Value: Boolean);
procedure SetAutoColWidth(Value: Boolean);
procedure SetReadOnly(Value: Boolean);
procedure InternalSetCell(X, Y: Integer; Value: string; FireOnChange: Boolean);
procedure SetCell(X, Y: Integer; Value: string);
function GetColWidths(Index: Integer): Integer;
procedure SetColWidths(Index: Integer; Value: Integer);
procedure SetColumns(Value: TNiceColumns);
procedure SetCol(Value: Integer);
procedure SetRow(Value: Integer);
procedure AdjustSelection(Value: TRect; Force: Boolean);
procedure SetSelectArea(Value: TRect);
procedure SetGutterKind(Value: TGutterKind);
procedure SetGutterWidth(Value: Integer);
procedure SetGutterFont(Value: TFont);
procedure HeaderFontChange(Sender: TObject);
procedure GutterFontChange(Sender: TObject);
function CreateColumn: TNiceColumn;
procedure UpdateColumn(Index: Integer);
procedure UpdateColumns;
procedure UpdateHeader;
function GetCellRect(x, y: Integer): TRect;
function CellRectToClient(R: TRect): TRect;
function GetCellAtPos(X, Y: Integer): TPoint;
function GetColFromX(X: Integer): Integer;
function GetRowFromY(Y: Integer): Integer;
function GetColCoord(I: Integer): Integer;
function GetCell(X, Y: Integer): string;
function SafeGetCell(X, Y: Integer): string;
function GetCellColor(X, Y: Integer): TColor;
procedure DrawCell(X, Y: Integer);
procedure InvalidateCell(X, Y: Integer);
function FastDrawCell(X, Y: Integer; IsEditing: Boolean): TPoint;
procedure ForceHideCaret;
procedure ForceShowCaret;
procedure NormalizeVertOffset;
procedure InvalidateCells;
procedure InvalidateRightWard(Left: Integer);
procedure InvalidateDownWard(Top: Integer);
procedure InvalidateHeader;
procedure InvalidateGutter;
function GetFirstVisible: Integer;
function GetLastVisible: Integer;
function GetNextVisible(Index: Integer): Integer;
function GetPrevVisible(Index: Integer): Integer;
procedure ColRowChanged;
procedure SetGutterStrings(const Value: TStrings);
function GetObject(X, Y: Integer): TObject;
procedure SetObject(X, Y: Integer; const Value: TObject);
procedure BuildMergeData;
procedure DrawMergedCell(Index: Integer);
procedure SetShowFooter(const Value: Boolean);
procedure RenderFooter;
procedure SetFooterFont(const Value: TFont);
procedure FooterFontChange(Sender: TObject);
procedure DrawFixCell(Rc: TRect; Str: string; AFont: TFont; AEvent: TOnDrawHeaderEvent);
procedure SetEnabled(const Value: Boolean); reintroduce;
protected
function GetMergedCellsData: TList;
function GetHeaderInfo: TList;
procedure SetScrollBar(AKind, AMax, APos, AMask: Integer); virtual;
procedure ShowHideScrollBar(HorzVisible, VertVisible: Boolean); virtual;
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure Recalculate; virtual;
procedure CreateWnd; override;
procedure CreateParams(var Params: TCreateParams); override;
procedure Paint; override;
procedure Loaded; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyPress(var Key: Char); override;
function TextExtent(const s: String): TSize;
{$IFDEF FPC}
procedure DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy; const AXProportion, AYProportion: Double); override;
{$ENDIF}
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure BeginUpdate;
procedure EndUpdate;
procedure Clear;
property Cells[X, Y: Integer]: string read GetCell write SetCell; default;
property Objects[X, Y: Integer]: TObject read GetObject write SetObject;
property ColWidths[Index: Integer]: Integer read GetColWidths write SetColWidths;
procedure EnsureVisible(X, Y: Integer); overload;
procedure CutToClipboard;
procedure CopyToClipboard;
procedure PasteFromClipboard;
function GetHitTestInfo(X, Y: Integer): TGridHitTest;
function HeaderCellsCount: Integer;
function HeaderCells(I: Integer): THeaderInfo;
property Col: Integer read FCol write SetCol;
property Row: Integer read FRow write SetRow;
property SelectArea: TRect read FSelectArea write SetSelectArea;
procedure DeleteRow(ARow: Integer);
procedure InsertRow(ARow: Integer);
function AddRow: Integer;
property HorzOffset: Integer read FHorzOffset write SetHorzOffset;
property VertOffset: Integer read FVertOffset write SetVertOffset;
function MergeCells(const X1, Y1, X2, Y2: Integer; ACaption: string): TMergeCell;
procedure ClearMergeCells;
{$IFDEF FPC}
procedure FixDesignFontsPPI(const ADesignTimePPI: Integer); override;
procedure ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double); override;
{$ENDIF}
published
property Enabled: Boolean read FEnabled write SetEnabled default True;
property ColCount: Integer read GetColCount write SetColCount;
property RowCount: Integer read FRowCount write SetRowCount default 5;
property AutoAddRow: Boolean read FAutoAddRow write FAutoAddRow default False;
property AutoFillDown: Boolean read FAutoFillDown write FAutoFillDown default False;
property AutoFillRight: Boolean read FAutoFillRight write FAutoFillRight default False;
property DefRowHeight: Integer read FDefRowHeight write SetDefRowHeight default 18;
property DefColWidth: Integer read FDefColWidth write SetDefColWidth default 80;
property Flat: Boolean read FFlat write SetFlat default True;
property Color: TColor read FColor write SetColor default clWindow;
property AlternateColor: TColor read FAlternateColor write SetAlternateColor default clWindow;
property GridColor: TColor read FGridColor write SetGridColor default clBtnFace;
property ShowGrid: Boolean read FShowGrid write SetShowGrid default True;
property HeaderLine: Integer read FHeaderLine write SetHeaderLine default 1;
property HeaderColor: TColor read FHeaderColor write SetHeaderColor default clBtnFace;
property HeaderLightColor: TColor read FHeaderLightColor write SetHeaderLightColor default clBtnHighlight;
property HeaderDarkColor: TColor read FHeaderDarkColor write SetHeaderDarkColor default clBtnShadow;
property HeaderFont: TFont read FHeaderFont write SetHeaderFont;
property FooterFont: TFont read FFooterFont write SetFooterFont;
property SelectionColor: TColor read FSelectionColor write SetSelectionColor default $00CAFFFF;
property FitToWidth: Boolean read FFitToWidth write SetFitToWidth default False;
property AutoColWidth: Boolean read FAutoColWidth write SetAutoColWidth default False;
property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
property Columns: TNiceColumns read FColumns write SetColumns;
property GutterKind: TGutterKind read FGutterKind write SetGutterKind default gkBlank;
property GutterWidth: Integer read FGutterWidth write SetGutterWidth default 20;
property GutterFont: TFont read FGutterFont write SetGutterFont;
property GutterStrings: TStrings read FGutterStrings write SetGutterStrings;
property ShowFooter: Boolean read FShowFooter write SetShowFooter;
property OnDrawCell: TOnDrawCellEvent read FOnDrawCell write FOnDrawCell;
property OnDrawHeader: TOnDrawHeaderEvent read FOnDrawHeader write FOnDrawHeader;
property OnDrawGutter: TOnDrawHeaderEvent read FOnDrawGutter write FOnDrawGutter;
property OnDrawFooter: TOnDrawHeaderEvent read FOnDrawFooter write FOnDrawFooter;
property OnFilterChar: TOnFilterChar read FOnFilterChar write FOnFilterChar;
property OnHeaderClick: TOnHeaderClick read FOnHeaderClick write FOnHeaderClick;
property OnGutterClick: TOnGutterClick read FOnGutterClick write FOnGutterClick;
property OnCellChange: TOnCellChange read FOnCellChange write FOnCellChange;
property OnCellChanging: TOnCellChanging read FOnCellChanging write FOnCellChanging;
property OnColRowChanged: TOnColRowChanged read FOnColRowChanged write FOnColRowChanged;
property OnInsertRow: TOnRowEvent read FOnInsertRow write FOnInsertRow;
property OnDeleteRow: TOnRowEvent read FOnDeleteRow write FOnDeleteRow;
property OnCellAssignment: TOnCellAssignment read FOnCellAssignment write FOnCellAssignment;
property Font;
property Anchors;
property Align;
{$IFDEF FPC}
property BorderSpacing;
{$ELSE}
property BevelKind;
{$ENDIF}
property BorderStyle default bsSingle;
property BevelOuter default bvNone;
property BevelInner;
property TabOrder;
property TabStop default True;
property Tag;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnKeyPress;
property OnKeyDown;
property OnKeyUp;
property PopupMenu;
end;
TNiceGridSync = class(TNiceGrid)
private
FGrid: TNiceGrid;
procedure SetGrid(const Value: TNiceGrid);
procedure SyncDeleteRow(Sender: TObject; ARow: Integer);
procedure SyncInsertRow(Sender: TObject; ARow: Integer);
procedure SyncColRow(Sender: TObject; ACol, ARow: Integer);
protected
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
procedure SetScrollBar(AKind, AMax, APos, AMask: Integer); override;
procedure ShowHideScrollBar(HorzVisible, VertVisible: Boolean); override;
property OnDeleteRow;
property OnInsertRow;
property OnColRowChanged;
public
constructor Create(AOwner: TComponent); override;
published
property Grid: TNiceGrid read FGrid write SetGrid;
end;
function DrawString(Canvas: TCanvas; Str: string; Rc: TRect;
HorzAlign: THorzAlign; VertAlign: TVertAlign; IsEditing: Boolean): TPoint;
procedure DrawStringMulti(Canvas: TCanvas; Str: string; Rc: TRect;
HorzAlign: THorzAlign; VertAlign: TVertAlign);
implementation
{$R NiceCursors.res}
uses
Math;
const
crPlus = 101;
crSmallCross = 102;
crRight = 103;
crDown = 104;
crLeftTop = 105;
CursorArray: array [TGridHitTest] of TCursor =
//(gtNone, gtLeftTop, gtLeft, gtTop, gtCell, gtColSizing, gtSmallBox);
{$IFDEF LCLGtk3} // Issue with loading cursors in GTK3 --> use predefined cursors.
(crDefault, crSizeSE, crSizeE, crSizeS, crHandPoint, crHSplit, crCross);
{$ELSE}
(crDefault, crLeftTop, crRight, crDown, crPlus, crHSplit, crSmallCross);
{$ENDIF}
GridStateArray: array[TGridHitTest] of TNiceGridState =
(gsNormal, gsSelAll, gsSelRow, gsSelCol, gsCell, gsColSize, gsBoxDrag);
MergeID = -2;
{$HINTS OFF}
procedure Unused(const A1); overload;
begin
end;
procedure Unused(const A1, A2); overload;
begin
end;
{$HINTS ON}
{ TNiceGrid }
constructor TNiceGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 200;
Height := 200;
inherited Color := clWindow;
BevelOuter := bvNone;
BorderStyle := bsSingle;
TabStop := True;
TabOrder := 0;
ParentColor := False;
ParentBackground := False;
ParentFont := False;
{$IFDEF VER150}
ControlStyle := ControlStyle + [csNeedsBorderPaint];
{$ENDIF}
FFlat := True;
FEnabled := True;
FColor := clWindow;
FAlternateColor := clWindow;
FGridColor := clBtnFace;
FShowGrid := True;
FHeaderColor := clBtnface;
FHeaderLightColor := clBtnHighlight;
FHeaderDarkColor := clBtnShadow;
FHeaderFont := TFont.Create;
FHeaderFont.OnChange := HeaderFontChange;
FSelectionColor := $00CAFFFF;
FFooterFont := TFont.Create;
FFooterFont.OnChange := FooterFontChange;
FDefRowHeight := 18;
FDefColWidth := 80;
FRowCount := 5;
FAutoAddRow := False;
FGutterKind := gkBlank;
FGutterWidth := 20;
FGutterFont := TFont.Create;
FGutterFont.OnChange := GutterFontChange;
FHorzOffset := 0;
FVertOffset := 0;
FMaxHScroll := 0;
FMaxVScroll := 0;
FSmallChange := FDefRowHeight;
FLargeChange := FDefRowHeight * 5;
ForcedColumn := -1;
AllWidth := 200;
AllHeight := 200;
FHeaderLine := 1;
FHeaderInfos := TList.Create;
ValidationEnabled := True;
CellBox := Rect(0, 0, 0, 0);
FCol := 0;
FRow := 0;
FCol2 := 0;
FRow2 := 0;
FSelectArea := Rect(0, 0, 0, 0);
IsEditing := False;
BuffString := '';
SmallBox := Rect(-1, -1, -1, -1);
SmallBoxArea := Rect(-1, -1, -1, -1);
SmallBoxPos := 0;
SizingCol := -1;
SizingColX := -1;
{$IFNDEF LCLGtk3} // Issue with loading cursors in GTK3.
Screen.Cursors[crPlus] := LoadCursor(hinstance, 'CR_PLUS');
Screen.Cursors[crSmallCross] := LoadCursor(hInstance, 'CR_CROSS');
Screen.Cursors[crRight] := LoadCursor(hinstance, 'CR_RIGHT');
Screen.Cursors[crDown] := LoadCursor(hinstance, 'CR_DOWN');
Screen.Cursors[crLeftTop] := LoadCursor(hinstance, 'CR_LEFTTOP');
{$ENDIF}
Cursor := crPlus;
FGridState := gsNormal;
FColumns := TNiceColumns.Create(Self);
FEdit := TNiceInplace.Create(Self);
FGutterStrings := TStringList.Create;
Mergeds := TList.Create;
end;
destructor TNiceGrid.Destroy;
begin
ClearMergeCells;
Mergeds.Free;
FGutterStrings.Free;
FEdit.Free;
FColumns.Free;
ClearHeaderInfos;
FHeaderInfos.Free;
FHeaderFont.Free;
FFooterFont.Free;
FGutterFont.Free;
inherited Destroy;
end;
procedure TNiceGrid.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or WS_HSCROLL or WS_VSCROLL;
end;
procedure TNiceGrid.CreateWnd;
begin
inherited CreateWnd;
ShowHideScrollBar(False, False);
Recalculate;
end;
procedure TNiceGrid.SetScrollBar(AKind, AMax, APos, AMask: Integer);
var Info: TScrollInfo;
begin
{$IFDEF FPC}
Info := Default(TScrollInfo);
{$ELSE}
FillChar(Info, SizeOf(TScrollInfo), 0);
{$ENDIF}
Info.cbSize := SizeOf(TScrollInfo);
Info.nMin := 0;
Info.nMax := AMax;
Info.nPos := APos;
Info.fMask := AMask;
SetScrollInfo(Handle, AKind, Info, TRUE);
if (AKind = SB_VERT) and Assigned(Sync) then
begin
if ((AMask and SIF_RANGE) <> 0)
then Sync.FMaxVScroll := AMax;
if ((AMask and SIF_POS) <> 0)
then Sync.VertOffset := APos;
end;
end;
procedure TNiceGrid.ShowHideScrollBar(HorzVisible, VertVisible: Boolean);
begin
ShowScrollBar(Handle, SB_HORZ, HorzVisible);
ShowScrollBar(Handle, SB_VERT, VertVisible);
end;
procedure TNiceGrid.WMHScroll(var Msg: {$IFDEF FPC}TLMVScroll{$ELSE}TWMVScroll{$ENDIF});
var
Old: Integer;
begin
ForceHideCaret;
Old := FHorzOffset;
case Msg.ScrollCode of
SB_LINELEFT:
FHorzOffset := FHorzOffset - FSmallChange;
SB_LINERIGHT:
FHorzOffset := FHorzOffset + FSmallChange;
SB_PAGELEFT:
FHorzOffset := FHorzOffset - FLargeChange;
SB_PAGERIGHT:
FHorzOffset := FHorzOffset + FLargeChange;
SB_THUMBTRACK:
FHorzOffset := Msg.Pos;
SB_THUMBPOSITION:
FHorzOffset := Msg.Pos;
end;
FHorzOffset := Max(0, Min(FMaxHScroll, FHorzOffset));
if (FHorzOffset <> Old) then
begin
SetScrollBar(SB_HORZ, 0, FHorzOffset, SIF_POS);
InvalidateRightWard(FixedWidth);
end;
end;
procedure TNiceGrid.WMVScroll(var Msg: {$IFDEF FPC}TLMHScroll{$ELSE}TWMHScroll{$ENDIF});
var
Old: Integer;
begin
ForceHideCaret;
Old := FVertOffset;
case Msg.ScrollCode of
SB_LINEUP:
FVertOffset := FVertOffset - FSmallChange;
SB_LINEDOWN:
FVertOffset := FVertOffset + FSmallChange;
SB_PAGEUP:
FVertOffset := FVertOffset - FLargeChange;
SB_PAGEDOWN:
FVertOffset := FVertOffset + FLargeChange;
SB_THUMBTRACK:
FVertOffset := Msg.Pos;
SB_THUMBPOSITION:
FVertOffset := Msg.Pos;
end;
FVertOffset := Max(0, Min(FMaxVScroll, FVertOffset));
NormalizeVertOffset;
if (FVertOffset <> Old) then
begin
SetScrollBar(SB_VERT, 0, FVertOffset, SIF_POS);
InvalidateDownWard(FixedHeight);
end;
end;
procedure TNiceGrid.SetColCount(Value: Integer);
begin
if (ColCount <> Value) then
begin
FColumns.BeginUpdate;
while (ColCount > Value)
do FColumns.Delete(FColumns.Count-1);
while (ColCount < Value)
do FColumns.Add;
FHorzOffset := 0;
FVertOffset := 0;
FCol := Max(0, Min(FCol, ColCount-1));
FRow := Max(0, Min(FRow, FRowCount-1));
if (FRowCount = 0) or (ColCount = 0) then
begin
FCol := -1;
FRow := -1;
end;
FSelectArea := Rect(FCol, FRow, FCol, FRow);
FColumns.EndUpdate;
ColRowChanged;
end;
end;
procedure TNiceGrid.SetRowCount(Value: Integer);
begin
if (FRowCount <> Value) then
begin
FRowCount := Value;
FCol := Max(0, Min(FCol, ColCount-1));
FRow := Max(0, Min(FRow, FRowCount-1));
if (FRowCount = 0) or (ColCount = 0) then
begin
FCol := -1;
FRow := -1;
end;
FSelectArea := Rect(FCol, FRow, FCol, FRow);
Recalculate;
Invalidate;
ColRowChanged;
end;
end;
procedure TNiceGrid.ClearHeaderInfos;
var
x: Integer;
P: PHeaderInfo;
begin
for x := 0 to FHeaderInfos.Count-1 do
begin
P := PHeaderInfo(FHeaderInfos[x]);
Dispose(P);
end;
FHeaderInfos.Clear;
end;
procedure TNiceGrid.Recalculate;
var
x: Integer;
HVisible, VVisible: Boolean;
VisCount: Integer;
WidthAvail, HeightAvail: Integer;
v: Integer;
LastBodyWidth: Integer;
bmp: TBitmap;
lCanvas: TCanvas;
function GetColAutoWidth(i: Integer): Integer;
var
n: Integer;
t: TStrings;
begin
Result := 0;
t := Columns[i].FStrings;
for n := 0 to t.Count-1 do
Result := Max(Result, lCanvas.TextWidth(t[n]) + 7);
Result := Max(Result, 20);
end;
begin
if csLoading in ComponentState then
exit;
BuildMergeData;
if Canvas.HandleAllocated then
begin
lCanvas := Canvas;
bmp := nil;
end else
begin
bmp := TBitmap.Create;
bmp.Width := 100;
bmp.Height := 100;
bmp.Canvas.Font.Assign(Font);
lCanvas := bmp.Canvas;
end;
VisCount := 0;
for x := 0 to FColumns.Count-1 do
begin
if FColumns[x].FVisible
then Inc(VisCount);
end;
if (VisCount = 0) then
begin
FixedHeight := 0;
FixedWidth := 0;
BodyWidth := 0;
BodyHeight := 0;
ShowHideScrollBar(False, False);
Exit;
end;
if FAutoColWidth then
begin
lCanvas.Font.Assign(Font);
for x := 0 to FColumns.Count-1
do FColumns[x].FWidth := Max(FDefColWidth, GetColAutoWidth(x));
end;
FixedWidth := 0;
if (FGutterKind <> gkNone)
then FixedWidth := FGutterWidth;
FixedHeight := FHeaderLine * FDefRowHeight;
BodyHeight := FRowCount * FDefRowHeight;
WidthAvail := ClientWidth - FixedWidth;
HeightAvail := ClientHeight - FixedHeight;
if FShowFooter
then HeightAvail := HeightAvail - FDefRowHeight;
BodyWidth := 0;
for x := 0 to FColumns.Count-1 do
begin
if FColumns[x].FVisible
then BodyWidth := BodyWidth + FColumns[x].FWidth;
end;
if FFitToWidth then
begin
if (BodyWidth < WidthAvail) then
begin
LastBodyWidth := BodyWidth;
x := 0;
while (BodyWidth < WidthAvail) do
begin
if (x > ColCount-1) then
begin
if (BodyWidth = LastBodyWidth)
then Break
else x := 0;
end;
if FColumns[x].FVisible and FColumns[x].FCanResize then
begin
FColumns[x].FWidth := FColumns[x].FWidth + 1;
Inc(BodyWidth);
end;
Inc(x);
end;
end;
if (BodyWidth > WidthAvail) then
begin
LastBodyWidth := BodyWidth;
x := 0;
while (BodyWidth > WidthAvail) do
begin
if (x > ColCount-1) then
begin
if (BodyWidth = LastBodyWidth)
then Break
else x := 0;
end;
if FColumns[x].FVisible and (x <> ForcedColumn) and FColumns[x].FCanResize then
begin
FColumns[x].FWidth := FColumns[x].FWidth - 1;
Dec(BodyWidth);
end;
Inc(x);
end;
end;
ForcedColumn := -1;
end;
if (BodyWidth < WidthAvail)
then FHorzOffset := 0;
if (BodyHeight < HeightAvail)
then FVertOffset := 0;
HVisible := BodyWidth > WidthAvail;
VVisible := BodyHeight > HeightAvail;
ShowHideScrollBar(HVisible, VVisible);
FMaxHScroll := Max(0, BodyWidth - ClientWidth + FixedWidth);
if FShowFooter
then FMaxVScroll := Max(0, BodyHeight - ClientHeight + FixedHeight + FDefRowHeight)
else FMaxVScroll := Max(0, BodyHeight - ClientHeight + FixedHeight);
// Align to FDefRowHeight
v := FMaxVScroll div FDefRowHeight;
if (FMaxVScroll mod FDefRowHeight) > 0
then Inc(v);
FMaxVScroll := v * FDefRowHeight;
if FShowFooter then
begin
if VVisible
then FooterTop := (((ClientHeight div FDefRowHeight) - 1) * FDefRowHeight) - 1
else FooterTop := (FDefRowHeight * (FHeaderLine + FRowCount)) - 1;
end;
FHorzOffset := Max(0, Min(FHorzOffset, FMaxHScroll));
FVertOffset := Max(0, Min(FVertOffset, FMaxVScroll));
SetScrollBar(SB_HORZ, FMaxHScroll, FHorzOffset, SIF_POS or SIF_RANGE);
SetScrollBar(SB_VERT, FMaxVScroll, FVertOffset, SIF_POS or SIF_RANGE);
AllWidth := Min(ClientWidth, BodyWidth + FixedWidth);
if FShowFooter then
begin
AllHeight := Min(ClientHeight, BodyHeight + FixedHeight + FDefRowHeight);
CellBox := Rect(FixedWidth, FixedHeight, ClientWidth, FooterTop);
end else
begin
AllHeight := Min(ClientHeight, BodyHeight + FixedHeight);
CellBox := Rect(FixedWidth, FixedHeight, ClientWidth, ClientHeight);
end;
bmp.Free;
end;
function DrawString(Canvas: TCanvas; Str: string; Rc: TRect;
HorzAlign: THorzAlign; VertAlign: TVertAlign; IsEditing: Boolean): TPoint;
var
w, h, x, y: Integer;
rw: Integer;
begin
w := Canvas.TextWidth(Str);
h := Canvas.TextHeight('gM');
x := 0;
y := 0;
rw := Rc.Right - rc.Left;
case HorzAlign of
haLeft:
begin
x := Rc.Left;
if (w > rw) and IsEditing
then x := Rc.Left - (w - rw);
end;
haCenter: x := Rc.Left + ((rw - w) div 2);
haRight: x := Rc.Right - w;
end;
case VertAlign of
vaTop: y := Rc.Top;
vaCenter: y := Rc.Top + (((Rc.Bottom - Rc.Top) - h) div 2);
vaBottom: y := Rc.Bottom - h;
end;
Canvas.TextRect(Rc, x, y, Str);
// Return next cursor position
Result := Point(Min(x + w + 1, Rc.Right), Rc.Top - 1);
end;
procedure DrawStringMulti(Canvas: TCanvas; Str: string; Rc: TRect;
HorzAlign: THorzAlign; VertAlign: TVertAlign);
var
w, h, x, y: Integer;
t: TStringList;
i: Integer;
dh: Integer;
begin
if Pos(';', Str) = 0 then
begin
DrawString(Canvas, Str, Rc, HorzAlign, VertAlign, False);
Exit;
end;
t := TStringList.Create;
t.Text := StringReplace(Str, ';', #13, [rfReplaceAll]);
h := Canvas.TextHeight('gM');
dh := Rc.Top + (((Rc.Bottom - Rc.Top) - (h * t.Count)) div 2);
for i := 0 to t.Count-1 do
begin
w := Canvas.TextWidth(t[i]);
x := 0;
y := 0;
case HorzAlign of
haLeft: x := Rc.Left;
haCenter: x := Rc.Left + (((Rc.Right - Rc.Left) - w) div 2);
haRight: x := Rc.Right - w;
end;
case VertAlign of
vaTop: y := Rc.Top + (i * h);
vaCenter: y := dh + (i * h);
vaBottom: y := Rc.Bottom - (h * (t.Count-i));
end;
Canvas.TextRect(Rc, x, y, t[i]);
end;
t.Free;
end;
function TNiceGrid.GetCellColor(X, Y: Integer): TColor;
var
cl: TColor;
R: TRect;
begin
cl := FColumns[x].Color;
if Odd(Y) then
begin
if (cl = FColor)
then cl := FAlternateColor;
end;
if FEnabled then
begin
with FSelectArea
do R := Rect(Left, Top, Right + 1, Bottom + 1);
if PtInRect(R, Point(X, Y)) then
begin
if not ((X = FCol) and (y = FRow))
then cl := FSelectionColor;
end;
end;
Result := cl;
end;
procedure TNiceGrid.DrawFixCell(Rc: TRect; Str: string; AFont: TFont; AEvent: TOnDrawHeaderEvent);
var
Rt: TRect;
Handled: Boolean;
begin
Handled := False;
with Canvas do
begin
// Clear area
if FFlat
then Pen.Color := FHeaderDarkColor
else Pen.Color := clBlack;
Brush.Style := bsSolid;
Brush.Color := FHeaderColor;
Font.Assign(AFont);
if not FEnabled
then Font.Color := FHeaderDarkColor;
if Assigned(AEvent)
then AEvent(Self, Canvas, Rc, Str, Handled);
if Handled
then Exit;
Rectangle(Rc);
// Draw text immediately
Brush.Style := bsClear;
Rt := Rect(Rc.Left + 2, Rc.Top + 2, Rc.Right - 3, Rc.Bottom - 3);
DrawStringMulti(Canvas, Str, Rt, haCenter, vaCenter);
// cosmetics
Pen.Color := FHeaderLightColor;
MoveTo(Rc.Left + 1, Rc.Bottom - 2);
LineTo(Rc.Left + 1, Rc.Top + 1);
LineTo(Rc.Right - 1, Rc.Top + 1);
if not FFlat then
begin
Pen.Color := FHeaderDarkColor;
MoveTo(Rc.Right - 2, Rc.Top + 1);
LineTo(Rc.Right - 2, Rc.Bottom - 2);
LineTo(Rc.Left, Rc.Bottom - 2);
end;
end;
end;
procedure TNiceGrid.RenderGutter;
const
ArrowWidth = 8;
var
x: Integer;
R, Dummy: TRect;
Str: string;
l, t, m: Integer;
GutterBox: TRect;
begin
if (FGutterKind = gkNone)
then Exit;
GutterBox := CellBox;
GutterBox.Left := 0;
for x := 0 to FRowCount-1 do
begin
R := Rect(-1, (x * FDefRowHeight) - 1, FGutterWidth, ((x + 1) * FDefRowHeight));
OffsetRect(R, 0, -FVertOffset + FixedHeight);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, R, GutterBox) then
begin
case FGutterKind of
gkBlank, gkPointer:
Str := '';
gkNumber:
Str := IntToStr(x + 1);
gkString:
if (x > FGutterStrings.Count-1)
then Str := ''
else Str := FGutterStrings[x];
end;
DrawFixCell(R, Str, FGutterFont, FOnDrawGutter);
// Draw pointer triangle
if (FGutterKind = gkpointer) and (x = FRow) then
begin
with Canvas do
begin
l := (FGutterWidth - ArrowWidth) div 2;
t := (FDefRowHeight - ArrowWidth) div 2;
m := R.Top + (FDefRowHeight div 2);
Pen.Color := FHeaderDarkColor;
MoveTo(l, R.Bottom - t);
LineTo(l, R.Top + t);
LineTo(l + ArrowWidth, m);
Pen.Color := FHeaderLightColor;
LineTo(l, R.Bottom - t);
end;
end;
end;
end;
end;
procedure TNicegrid.RenderHeader;
var
x: Integer;
R, Dummy: TRect;
P: PHeaderInfo;
begin
Canvas.Font.Assign(FHeaderFont);
for x := 0 to FHeaderInfos.Count-1 do
begin
P := PHeaderInfo(FHeaderInfos[x]);
R := Rect(
GetColCoord(P^.Rc.Left) - 1,
(FDefRowHeight * P^.Rc.Top) - 1,
GetColCoord(P^.Rc.Right + 1),
FDefRowHeight * (P^.Rc.Bottom + 1)
);
OffsetRect(R, -FHorzOffset + FixedWidth, 0);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, R, ClientRect)
then DrawFixCell(R, P^.Str, FHeaderFont, FOnDrawHeader);
end;
R := Rect(-1, -1, FixedWidth, FixedHeight);
DrawFixCell(R, '', FHeaderFont, FOnDrawHeader);
end;
procedure TNiceGrid.RenderFooter;
var
x: Integer;
R, Dummy: TRect;
FooterBottom: Integer;
Right: Integer;
begin
Canvas.Font.Assign(FFooterFont);
FooterBottom := FooterTop + FDefRowHeight + 1;
for x := 0 to FColumns.Count-1 do
begin
R := Rect(GetColCoord(x)-1, FooterTop, GetColCoord(x+1), FooterBottom);
OffsetRect(R, -FHorzOffset + FixedWidth, 0);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, R, ClientRect)
then DrawFixCell(R, FColumns[x].FFooter, FFooterFont, FOnDrawFooter);
end;
R := Rect(-1, FooterTop, FixedWidth, FooterBottom);
DrawFixCell(R, '', FFooterFont, FOnDrawFooter);
Right := Min(AllWidth, ClientWidth);
R := Rect(-1, FooterBottom-1, Right, ClientHeight);
DrawFixCell(R, '', FFooterFont, FOnDrawFooter);
end;
procedure TNiceGrid.DrawCell(X, Y: Integer);
var
Rc, Dummy: TRect;
Column: TNiceColumn;
Handled: Boolean;
begin
Handled := False;
Rc := GetCellRect(x, y);
OffsetRect(Rc, -FHorzOffset + FixedWidth, -FVertOffset + FixedHeight);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, Rc, CellBox) then
begin
Column := FColumns[x];
with Canvas do
begin
Font.Assign(Column.Font);
if not FEnabled
then Font.Color := FGridColor;
Pen.Color := FGridColor;
Brush.Color := GetCellColor(X, Y);
if Assigned(FOnDrawCell)
then FOnDrawCell(Self, Canvas, X, Y, Rc, Handled);
if not Handled then
begin
Brush.Style := bsSolid;
if FShowGrid
then Rectangle(Rc)
else FillRect(Rc);
Brush.Style := bsClear;
InflateRect(Rc, -4, -2);
DrawString(Canvas, SafeGetCell(x, y), Rc, Column.HorzAlign,
Column.VertAlign, False);
end;
end;
end;
end;
procedure TNiceGrid.InvalidateCell(X, Y: Integer);
var
Rc: TRect;
begin
Rc := GetCellRect(X, Y);
InvalidateRect(Handle, @Rc, false);
end;
function TNiceGrid.FastDrawCell(X, Y: Integer; IsEditing: Boolean): TPoint;
var
R, Dummy: TRect;
Handled: Boolean;
Column: TNiceColumn;
begin
Handled := False;
Result := Point(-1, -1);
R := GetCellRect(x, y);
OffsetRect(R, -FHorzOffset + FixedWidth, -FVertOffset + FixedHeight);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, R, CellBox) then
begin
Column := FColumns[x];
with Canvas do
begin
Brush.Color := GetCellColor(X, Y);
Font.Assign(Column.Font);
end;
if Assigned(FOnDrawCell)
then FOnDrawCell(Self, Canvas, X, Y, R, Handled);
if not Handled then
begin
with Canvas do
begin
Brush.Style := bsSolid;
InflateRect(R, -4, -2);
FillRect(R);
Brush.Style := bsClear;
end;
Result := DrawString(Canvas, SafeGetCell(x, y), R, Column.HorzAlign,
Column.VertAlign, IsEditing);
end;
end;
end;
procedure TNiceGrid.DrawSelection;
var
R, R1, R2: TRect;
HOffset, VOffset: Integer;
boxSize: Integer;
boxSize2: Integer;
begin
if (FCol = -1) or (FRow = -1)
then Exit;
HOffset := - FHorzOffset + FixedWidth;
VOffset := - FVertOffset + FixedHeight;
R1 := GetCellRect(FSelectArea.Left, FSelectArea.Top);
R2 := GetCellRect(FSelectArea.Right, FSelectArea.Bottom);
R := Rect(R1.Left, R1.Top, R2.Right, R2.Bottom);
OffsetRect(R, HOffset, VOffset);
with Canvas do
begin
if Focused
then Pen.Color := clBlack
else Pen.Color := FGridColor;
Pen.Width := 3;
Brush.Style := bsClear;
Rectangle(R);
Pen.Width := 1;
Brush.Style := bsSolid;
if Focused
then Brush.Color := clBlack
else Brush.Color := FGridColor;
Pen.Color := clWhite;
boxSize2 := 6;
{$IFDEF FPC}
boxSize2 := Scale96ToFont(boxSize2);
{$ENDIF}
boxSize := boxSize2 div 2;
case SmallBoxPos of
0: SmallBox := Rect(R.Right, R.Bottom, R.Right, R.Bottom);
1: SmallBox := Rect(R.Right, R.Top + boxSize2-1, R.Right, R.Top + boxSize2-1);
2: SmallBox := Rect(R.Left + boxSize2-1, R.Bottom, R.Left + boxSize2-1, R.Bottom);
end;
InflateRect(SmallBox, boxSize, boxSize);
{
case SmallBoxPos of
0: SmallBox := Rect(R.Right - 3, R.Bottom - 3, R.Right + 3, R.Bottom + 3);
1: SmallBox := Rect(R.Right - 3, R.Top - 3 + 5, R.Right + 3, R.Top + 3 + 5);
2: SmallBox := Rect(R.Left - 3 + 5, R.Bottom - 3, R.Left + 3 + 5, R.Bottom + 3);
end;
}
Rectangle(SmallBox);
SmallBoxPos := 0; // Reset to Right Bottom
end;
if (SmallBoxArea.Left <> -1) then
begin
R1 := GetCellRect(SmallBoxArea.Left, SmallBoxArea.Top);
OffsetRect(R1, HOffset, VOffset);
R2 := GetCellRect(SmallBoxArea.Right, SmallBoxArea.Bottom);
OffsetRect(R2, HOffset, VOffset);
R := Rect(R1.Left, R1.Top, R2.Right, R2.Bottom);
with Canvas do
begin
Pen.Color := clBlack;
Pen.Width := 1;
Pen.Style := psDot;
Brush.Style := bsClear;
Rectangle(R);
Pen.Style := psSolid;
Pen.Width := 1;
end;
end;
end;
procedure TNiceGrid.ClearUnused;
var
t: Integer;
begin
if (AllWidth < ClientWidth) then
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FColor;
FillRect(Rect(AllWidth, 0, ClientWidth, ClientHeight));
end;
end;
if FShowFooter
then Exit;
if (AllHeight < ClientHeight) then
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FColor;
FillRect(Rect(0, AllHeight, ClientWidth, ClientHeight));
end;
end;
if ((FMaxVScroll - FVertOffset) < FDefRowHeight) then
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FColor;
t := FixedHeight + (((ClientHeight - FixedHeight) div FDefRowHeight) * FDefRowHeight);
FillRect(Rect(0, t, ClientWidth, ClientHeight));
end;
end;
end;
procedure TNiceGrid.Paint;
var
x, y: Integer;
RgnInv, RgnAll, RgnBody, RgnSel, Temp: HRGN;
HOffset, VOffset: Integer;
R, R1, R2: TRect;
begin
if FUpdating then Exit;
if not HandleAllocated then Exit;
if (ColCount = 0) then
begin
with Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := FColor;
FillRect(Rect(0, 0, ClientWidth, ClientHeight));
end;
Exit;
end;
if (FRowCount > 0) then
begin
// Calculating area that will be covered by selection rectangle
HOffset := - FHorzOffset + FixedWidth;
VOffset := - FVertOffset + FixedHeight;
R1 := GetCellRect(FSelectArea.Left, FSelectArea.Top);
R2 := GetCellRect(FSelectArea.Right, FSelectArea.Bottom);
R := Rect(R1.Left, R1.Top, R2.Right, R2.Bottom);
OffsetRect(R, HOffset, VOffset);
// Creating region, excluding selection rectangle to reduce flicker
RgnSel := CreateRectRgn(R.Left-1, R.Top-1, R.Right+1, R.Bottom+1);
Temp := CreateRectRgn(R.Left+2, R.Top+2, R.Right-2, R.Bottom-2);
CombineRgn(RgnSel, RgnSel, Temp, RGN_XOR);
if FShowFooter
then RgnInv := CreateRectRgn(FixedWidth, FixedHeight, ClientWidth, FooterTop)
else RgnInv := CreateRectRgn(FixedWidth, FixedHeight, ClientWidth, ClientHeight);
if FEnabled
then CombineRgn(RgnInv, RgnInv, RgnSel, RGN_DIFF);
SelectClipRgn(Canvas.Handle, RgnInv);
for x := 0 to ColCount-1 do
begin
if FColumns[x].FVisible then
begin
for y := 0 to FRowCount-1 do
begin
if (Integer(GetObject(x, y)) <> MergeID)
then DrawCell(X, Y);
end;
end;
end;
for x := 0 to Mergeds.Count-1
do DrawMergedCell(x);
RgnAll := CreateRectRgn(0, 0, ClientWidth, ClientHeight);
if FEnabled
then CombineRgn(RgnAll, RgnAll, RgnSel, RGN_DIFF);
SelectClipRgn(Canvas.Handle, RgnAll);
ClearUnused;
if FShowFooter
then RgnBody := CreateRectRgn(FixedWidth, FixedHeight, ClientWidth, FooterTop)
else RgnBody := CreateRectRgn(FixedWidth, FixedHeight, ClientWidth, ClientHeight);
SelectClipRgn(Canvas.Handle, RgnBody);
if FEnabled
then DrawSelection;
SelectClipRgn(Canvas.Handle, 0);
DeleteObject(RgnInv);
DeleteObject(RgnAll);
DeleteObject(RgnBody);
DeleteObject(RgnSel);
DeleteObject(Temp);
end else
ClearUnused;
RenderGutter;
RenderHeader;
if FShowFooter
then RenderFooter;
end;
procedure TNiceGrid.UpdateHeader;
var
P: PHeaderInfo;
x, y: Integer;
t: TStringList;
s: string;
LastX: TList;
LastY: PHeaderInfo;
Blank: PHeaderInfo;
begin
ClearHeaderInfos;
LastX := TList.Create;
t := TStringList.Create;
Blank := New(PHeaderInfo);
Blank^.Str := '^%%%%%^******^';
while (LastX.Count < FHeaderLine)
do LastX.Add(Blank);
P := nil;
for x := 0 to FColumns.Count-1 do
begin
if not FColumns[x].FVisible then
begin
for y := 0 to FHeaderLine-1
do LastX[y] := Blank;
Continue;
end;
t.Text := StringReplace(FColumns[x].Title, '|', #13, [rfReplaceAll]);
while (t.Count < FHeaderLine) do
begin
if (t.Count = 0)
then t.Add('')
else t.Add( t[t.Count-1]);
end;
LastY := Blank;
for y := 0 to FHeaderLine-1 do
begin
s := t[y];
if (s = LastY.Str) then
begin
LastY^.Rc.Bottom := Min(FHeaderLine-1, Max(LastY^.Rc.Bottom, y));
end else
begin
if (s = PHeaderInfo(LastX[y])^.Str) then
begin
P := PHeaderInfo(LastX[y]);
P^.Rc.Right := P^.Rc.Right + 1;
end else
begin
P := New(PHeaderInfo);
P^.Rc := Rect(x, y, x, y);
P^.Str := s;
FHeaderInfos.Add(P);
end;
LastX[y] := P;
end;
LastY := P;
end;
end;
LastX.Free;
t.Free;
Dispose(Blank);
Recalculate;
end;
function TNiceGrid.GetColCoord(I: Integer): Integer;
var
x: Integer;
Column: TNiceColumn;
begin
Result := 0;
for x := 0 to I-1 do
begin
Column := FColumns[x];
if Column.FVisible
then Result := Result + Column.FWidth;
end;
end;
function TNiceGrid.GetCellRect(x, y: Integer): TRect;
var
l, t, w, h: Integer;
begin
if (x = -1) or (y = -1) then
begin
Result := Rect(0, 0, 0, 0);
Exit;
end;
l := GetColCoord(x);
t := FDefRowheight * y;
w := 0;
if (FColumns[x].FVisible)
then w := FColumns[x].FWidth;
h := FDefRowHeight;
Result := Rect(l-1, t-1, l + w, t + h);
end;
function TNiceGrid.CellRectToClient(R: TRect): TRect;
begin
Result := R;
OffsetRect(Result, - FHorzOffset + FixedWidth, - FVertOffset + FixedHeight);
end;
function TNiceGrid.GetCellAtPos(X, Y: Integer): TPoint;
var
ax, ay: Integer;
begin
ax := (FHorzOffset + X) - FixedWidth;
ay := (FVertOffset + Y) - FixedHeight;
Result.X := 0;
while (GetColCoord(Result.X) < ax) do
begin
Result.X := Result.X + 1;
if (Result.X > FColumns.Count-1)
then Break;
end;
Result.X := Max(0, Result.X - 1);
Result.Y := Max(0, Min(ay div FDefRowHeight, FRowCount-1));
end;
function TNiceGrid.GetColFromX(X: Integer): Integer;
var
ax: Integer;
begin
if (X < FixedWidth) then
begin
Result := -1;
Exit;
end;
Result := 0;
ax := (FHorzOffset + X) - FixedWidth;
while (GetColCoord(Result) < ax) do
begin
Result := Result + 1;
if (Result > FColumns.Count-1)
then Break;
end;
Result := Result - 1;
if (Result > FColumns.Count-1) or (Result < 0)
then Result := -1;
end;
function TNiceGrid.GetRowFromY(Y: Integer): Integer;
var
ay: Integer;
begin
if (Y < FixedHeight) then
begin
Result := -1;
Exit;
end;
ay := (FVertOffset + Y) - FixedHeight;
Result := ay div FDefRowHeight;
if (Result > FRowCount-1)
then Result := -1;
end;
function TNiceGrid.SafeGetCell(X, Y: Integer): string;
var
t: TStringList;
begin
Result := '';
t := TStringList(Columns[X].FStrings);
if (Y < t.Count)
then Result := t[Y];
end;
function TNiceGrid.GetCell(X, Y: Integer): string;
var
t: TStrings;
begin
Result := '';
if (X > ColCount-1) or (Y > FRowCount-1)
then raise Exception.Create('Cell Index out of bound.');
t := Columns[X].FStrings;
if (Y < t.Count)
then Result := t[Y];
end;
procedure TNiceGrid.InternalSetCell(X, Y: Integer; Value: string;
FireOnChange: Boolean);
var
t: TStringList;
s: string;
CanChange: Boolean;
begin
if (ColCount = 0) or (FRowCount = 0)
then Exit;
if FireOnChange and FColumns[X].FReadOnly
then Exit;
if (X > ColCount-1) or (Y > FRowCount-1)
then raise Exception.Create('Cell Index out of bound.');
t := TStringList(FColumns[X].FStrings);
while (Y > t.Count-1)
do t.Add('');
if (t[Y] = Value)
then Exit;
if FireOnChange then
begin
s := Value;
CanChange := True;
if Assigned(FOnCellChanging)
then FOnCellChanging(Self, X, Y, CanChange);
if not CanChange
then Exit;
if Assigned(FOnCellChange)
then FOnCellChange(Self, X, Y, s);
t[Y] := s;
end else
t[Y] := Value;
if not FUpdating
then InvalidateCell(X, Y);
// then FastDrawCell(X, Y, False);
end;
procedure TNiceGrid.SetCell(X, Y: Integer; Value: string);
begin
InternalSetCell(X, Y, Value, False);
end;
procedure TNiceGrid.BeginUpdate;
begin
FUpdating := True;
ForceHideCaret;
end;
procedure TNiceGrid.EndUpdate;
begin
FUpdating := False;
UpdateHeader;
Invalidate;
end;
procedure TNiceGrid.SetFlat(Value: Boolean);
begin
if (FFlat <> Value) then
begin
FFlat := Value;
Invalidate;
end;
end;
procedure TNiceGrid.SetColor(Value: TColor);
begin
if (FColor <> Value) then
begin
FColor := Value;
inherited Color := Value;
Invalidate;
end;
end;
procedure TNiceGrid.SetAlternateColor(Value: TColor);
begin
if (FAlternateColor <> Value) then
begin
FAlternateColor := Value;
InvalidateCells;
end;
end;
procedure TNiceGrid.SetGridColor(Value: TColor);
begin
if (FGridColor <> Value) then
begin
FGridColor := Value;
InvalidateCells;
end;
end;
function TNiceGrid.GetColWidths(Index: Integer): Integer;
begin
Result := FColumns[Index].FWidth;
end;
procedure TNiceGrid.SetColWidths(Index, Value: Integer);
begin
if not FAutoColWidth then
begin
if (ColWidths[Index] <> Value)
then FColumns[Index].Width := Value;
end;
end;
procedure TNiceGrid.SetAutoColWidth(Value: Boolean);
begin
if (FAutoColWidth <> Value) then
begin
FAutoColWidth := Value;
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.SetDefColWidth(Value: Integer);
begin
if (FDefColWidth <> Value) then
begin
FDefColWidth := Value;
if not FAutoColWidth then
begin
Recalculate;
Invalidate;
end;
end;
end;
procedure TNiceGrid.SetDefRowHeight(Value: Integer);
begin
if (FDefRowHeight <> Value) then
begin
FDefRowHeight := Value;
FSmallChange := Value;
FLargeChange := Value * 5;
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.SetFitToWidth(Value: Boolean);
begin
if (FFitToWidth <> Value) then
begin
FFitToWidth := Value;
FHorzOffset := 0;
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.SetHeaderColor(Value: TColor);
begin
if (FHeaderColor <> Value) then
begin
FHeaderColor := Value;
Invalidate;
end;
end;
procedure TNiceGrid.SetHeaderDarkColor(Value: TColor);
begin
if (FHeaderDarkColor <> Value) then
begin
FHeaderDarkColor := Value;
Invalidate;
end;
end;
procedure TNiceGrid.SetHeaderLightColor(Value: TColor);
begin
if (FHeaderLightColor <> Value) then
begin
FHeaderLightColor := Value;
Invalidate;
end;
end;
procedure TNiceGrid.SetHeaderLine(Value: Integer);
begin
if (FHeaderLine <> Value) then
begin
FHeaderLine := Value;
UpdateHeader;
Invalidate;
end;
end;
procedure TNiceGrid.SetSelectionColor(Value: TColor);
begin
if (FSelectionColor <> Value) then
begin
FSelectionColor := Value;
InvalidateCells;
end;
end;
procedure TNiceGrid.KeyDown(var Key: Word; Shift: TShiftState);
var
l, t, r, b: Integer;
x, y: Integer;
Empty: Boolean;
Str: string;
FillDown: Boolean;
FillRight: Boolean;
Old: Integer;
OldS: string;
procedure UpdateColRow;
begin
ForceHideCaret;
FUpdating := True;
BuffString := '';
FCol2 := FCol;
FRow2 := FRow;
EnsureVisible(FCol, FRow);
FUpdating := False;
SetSelectArea(Rect(FCol, FRow, FCol, FRow));
ColRowChanged;
end;
procedure UpdateSelectArea;
begin
l := Min(FCol2, FCol);
t := Min(FRow2, FRow);
r := Max(FCol2, FCol);
b := Max(FRow2, FRow);
SetSelectArea(Rect(l, t, r, b));
EnsureVisible(FCol2, FRow2);
end;
begin
if not FEnabled
then Exit;
if (ColCount = 0) or (FRowCount = 0)
then Exit;
if (ssCtrl in Shift) then
begin
case Key of
Ord('X'), Ord('x'):
if not FReadOnly
then CutToClipboard;
Ord('C'), Ord('c'):
CopyToClipboard;
Ord('V'), Ord('v'):
if not FReadOnly
then PasteFromClipboard;
VK_HOME:
begin
FCol := GetFirstVisible;
FRow := 0;
UpdateColRow;
end;
VK_END:
begin
FCol := GetLastVisible;
FRow := FRowCount-1;
UpdateColRow;
end;
VK_DELETE:
begin
if not FReadOnly and (FRowCount > 1) then
begin
Old := FRow;
DeleteRow(FRow);
if Assigned(FOnDeleteRow)
then FOnDeleteRow(Self, Old);
UpdateColRow;
end;
end;
end;
end else
if (ssShift in Shift) then
begin
case Key of
VK_LEFT:
begin
FCol2 := Max(GetPrevVisible(FCol2), GetFirstVisible);
UpdateSelectArea;
end;
VK_RIGHT:
begin
FCol2 := Min(GetNextVisible(FCol2), GetLastVisible);
UpdateSelectArea;
end;
VK_UP:
begin
FRow2 := Max(FRow2 - 1, 0);
UpdateSelectArea;
end;
VK_DOWN:
begin
FRow2 := Min(FRow2 + 1, FRowCount-1);
UpdateSelectArea;
end;
VK_RETURN:
if (FSelectArea.Left = FSelectArea.Right)
and (FSelectArea.Top = FSelectArea.Bottom) then
begin
FRow := Max(0, FRow - 1);
UpdateColRow;
end else
begin
if (FCol = FSelectArea.Left) and (FRow = FSelectArea.Top) then
begin
FCol := FSelectArea.Right;
FRow := FSelectArea.Bottom;
end else
if (FRow = FSelectArea.Top) then
begin
FCol := FCol - 1;
FRow := FSelectArea.Bottom;
end else
begin
FRow := Row - 1;
end;
ForceHideCaret;
BuffString := '';
EnsureVisible(FCol, FRow);
InvalidateCells;
ColRowChanged;
end;
end;
end else
begin
case Key of
VK_HOME:
begin
FCol := GetFirstVisible;
UpdateColRow;
end;
VK_END:
begin
FCol := GetLastVisible;
UpdateColRow;
end;
VK_PRIOR:
begin
FRow := 0;
UpdateColRow;
end;
VK_NEXT:
begin
FRow := FRowCount-1;
UpdateColRow;
end;
VK_LEFT:
begin
FCol := Max(GetPrevVisible(FCol), GetFirstVisible);
UpdateColRow;
end;
VK_RIGHT:
begin
FCol := Min(GetNextVisible(FCol), GetLastVisible);
UpdateColRow;
end;
VK_UP:
begin
if FAutoAddRow and (FRow = (FRowCount-1)) and (FRow > 0) and not FReadOnly then
begin
Empty := True;
for x := 0 to ColCount-1 do
begin
if (SafeGetCell(x, FRowCount-1) <> '') then
begin
Empty := False;
Break;
end;
end;
if Empty then
begin
RowCount := RowCount - 1;
FRow := FRowCount - 1;
if Assigned(FOnDeleteRow)
then FOnDeleteRow(Self, FRowCount);
end else
FRow := Max(0, FRow - 1);
end else
FRow := Max(0, FRow - 1);
UpdateColRow;
end;
VK_DOWN:
begin
if FAutoAddRow and (FRow = (FRowCount-1)) and not FReadOnly then
begin
Inc(FRow);
RowCount := RowCount + 1;
if Assigned(FOnInsertRow)
then FOnInsertRow(Self, FRow);
end else
FRow := Min(FRowCount - 1, FRow + 1);
UpdateColRow;
end;
{$IFDEF FPC}
VK_F2:
begin
{
BuffString := '';
Pt := GetCellAtPos(X, Y);
FCol := Pt.X;
FRow := Pt.Y;
// if (Pt.X = FCol) and (Pt.Y = FRow) then
begin
}
EnsureVisible(FCol, FRow);
if (not FReadOnly) and (not FColumns[FCol].FReadOnly) then
begin
IsEditing := True;
FEdit.ShowEdit(FCol, FRow);
FEdit.SelectAll;
end;
//end;
end;
{$ENDIF}
VK_RETURN:
begin
OldS := GetCell(Col, Row);
Str := OldS;
if Assigned(FOnCellAssignment)
then FOnCellAssignment(Self, Col, Row, Str);
if (Str <> Olds)
then InternalSetCell(Col, Row, Str, True);
FillDown := FAutoFillDown and (Copy(Str, Length(Str), 1) = '*');
FillRight := FAutoFillRight and (Copy(Str, Length(Str), 1) = '>');
if (FSelectArea.Left = FSelectArea.Right)
and (FSelectArea.Top = FSelectArea.Bottom) then
begin
if FillDown then
begin
BuffString := '';
ForceHideCaret;
Str := Copy(Str, 1, Length(Str) - 1);
for y := Row to FRowCount-1
do Cells[Col, y] := Str;
end else
if FillRight then
begin
BuffString := '';
ForceHideCaret;
Str := Copy(Str, 1, Length(Str) - 1);
for x := Col to ColCount-1
do Cells[x, Row] := Str;
end else
begin
FRow := Min(FRowCount - 1, FRow + 1);
UpdateColRow;
end;
end else
begin
if FillDown then
begin
BuffString := '';
ForceHideCaret;
Str := Copy(Str, 1, Length(Str) - 1);
for y := Row to FSelectArea.Bottom
do Cells[Col, y] := Str;
end else
if FillRight then
begin
BuffString := '';
ForceHideCaret;
Str := Copy(Str, 1, Length(Str) - 1);
for x := Col to FSelectArea.Right
do Cells[x, Row] := Str;
end else
begin
if (FCol = FSelectArea.Right) and (FRow = FSelectArea.Bottom) then
begin
FCol := FSelectArea.Left;
FRow := FSelectArea.Top;
end else
if (FRow = FSelectArea.Bottom) then
begin
FCol := FCol + 1;
FRow := FSelectArea.Top;
end else
begin
FRow := Row + 1;
end;
ForceHideCaret;
BuffString := '';
EnsureVisible(FCol, FRow);
InvalidateCells;
ColRowChanged;
end;
end;
end;
VK_DELETE:
begin
if (BuffString = '') then
begin
if not FReadOnly then
begin
FUpdating := True;
for x := SelectArea.Left to SelectArea.Right do
begin
for y := SelectArea.Top to SelectArea.Bottom
do InternalSetCell(X, Y, '', True);
end;
FUpdating := False;
InvalidateCells;
end;
end;
end;
VK_INSERT:
begin
if not FReadOnly then
begin
InsertRow(Max(0, FRow));
if Assigned(FOnInsertRow)
then FOnInsertRow(Self, FRow);
UpdateColRow;
end;
end;
end;
end;
inherited;
end;
procedure TNiceGrid.KeyPress(var Key: Char);
var
Pt: TPoint;
Allowed: Boolean;
begin
inherited;
if not FEnabled
then Exit;
if (ColCount = 0) or (FRowCount = 0)
then Exit;
if not FReadOnly then
begin
case Key of
Chr(VK_BACK):
begin
ForceHideCaret;
BuffString := Copy(BuffString, 1, Length(BuffString) - 1);
InternalSetCell(FCol, FRow, BuffString, True);
EnsureVisible(FCol, FRow);
Pt := FastDrawCell(FCol, FRow, True);
SetCaretPos(Pt.X, Pt.Y);
ForceShowCaret;
end;
Chr($20)..Chr($FF):
begin
Allowed := True;
if Assigned(FOnFilterChar)
then FOnFilterChar(Self, FCol, FRow, Key, Allowed);
if Allowed then
begin
ForceHideCaret;
BuffString := BuffString + Key;
InternalSetCell(FCol, FRow, BuffString, True);
EnsureVisible(FCol, FRow);
Pt := FastDrawCell(FCol, FRow, True);
SetCaretPos(Pt.X, Pt.Y);
ForceShowCaret;
end;
end;
end;
end;
end;
function TNiceGrid.TextExtent(const s: String): TSize;
var
bmp: TBitmap;
begin
if Canvas.HandleAllocated then
Result := Canvas.TextExtent(s)
else
begin
bmp := TBitmap.Create;
try
bmp.Width := 100;
bmp.Height := 100;
bmp.Canvas.Font.Assign(self.Font);
Result := bmp.Canvas.TextExtent(s);
finally
bmp.Free;
end;
end;
end;
function TNiceGrid.GetHitTestInfo(X, Y: Integer): TGridHitTest;
var
a, i1, i2: Integer;
ax, ay: Integer;
IsSizing: Boolean;
begin
Result := gtNone;
IsSizing := False;
ax := (FHorzOffset + X) - FixedWidth;
ay := (FVertOffset + Y) - FixedHeight;
if not FAutoColWidth then
begin
for a := 1 to ColCount do
begin
i1 := GetColCoord(a);
i2 := X + FHorzOffset - FixedWidth;
if (i2 > (i1-2)) and (i2 < (i1+2)) then
begin
SizingCol := a - 1;
IsSizing := FColumns[SizingCol].FCanResize;
Break;
end;
end;
end;
if PtInRect(SmallBox, Point(X, Y))
then Result := gtSmallBox else
if IsSizing
then Result := gtColSizing else
if ((X < FixedWidth) and (Y < FixedHeight))
then Result := gtLeftTop else
if ((X < FixedWidth) and (Y > FixedHeight) and (ay < BodyHeight))
then Result := gtLeft else
if ((Y < FixedHeight) and (X > FixedWidth) and (ax < BodyWidth))
then Result := gtTop else
if ((X > FixedWidth) and (Y > FixedHeight) and (ax < BodyWidth) and (ay < BodyHeight))
then Result := gtCell;
end;
procedure TNiceGrid.Loaded;
begin
inherited;
Recalculate;
end;
procedure TNiceGrid.MouseDown(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
Pt: TPoint;
begin
if not FEnabled then
begin
inherited;
Exit;
end;
case FGridState of
gsColSize:
begin
ForceHideCaret;
SizingColX := GetColCoord(SizingCol);
end;
gsBoxDrag:
begin
ForceHideCaret;
SmallBoxArea := FSelectArea;
end;
gsSelAll:
begin
FRow := 0;
FCol := 0;
BuffString := '';
EnsureVisible(0, 0);
FCol2 := ColCount-1;
FRow2 := FRowCount-1;
SetSelectArea(Rect(0, 0, ColCount-1, FRowCount-1));
ColRowChanged;
end;
gsSelRow:
begin
FRow := GetRowFromY(Y);
FCol := 0;
LastHover := FRow;
BuffString := '';
EnsureVisible(FCol, FRow);
FCol2 := ColCount-1;
FRow2 := FRow;
SmallBoxPos := 2;
AdjustSelection(Rect(0, FRow, ColCount-1, FRow), True);
ColRowChanged;
if Assigned(OnGutterClick)
then FOnGutterClick(Self, FRow, Button, Shift);
end;
gsSelCol:
begin
FCol := GetColFromX(X);
FRow := 0;
LastHover := FCol;
BuffString := '';
EnsureVisible(FCol, FRow);
FCol2 := FCol;
FRow2 := FRowCount-1;
SmallBoxPos := 1;
AdjustSelection(Rect(FCol, 0, FCol, FRowCount-1), True);
ColRowChanged;
if Assigned(FOnHeaderClick)
then FOnHeaderClick(Self, FCol, Button, Shift);
end;
gsCell:
begin
BuffString := '';
Pt := GetCellAtPos(X, Y);
if (Pt.X = FCol) and (Pt.Y = FRow) then
begin
EnsureVisible(FCol, FRow);
if (not FReadOnly) and (not FColumns[FCol].FReadOnly) then
begin
IsEditing := True;
FEdit.ShowEdit(FCol, FRow);
end;
end else
if (Pt.X <> -1) and (pt.Y <> -1) then
begin
EnsureVisible(Pt.X, Pt.Y);
FCol := Pt.X;
FRow := Pt.Y;
BuffString := '';
FCol2 := FCol;
FRow2 := FRow;
SetSelectArea(Rect(FCol, FRow, FCol, FRow));
end;
ColRowChanged;
end;
end;
(*
if (Cursor = crHSplit) then
begin
ForceHideCaret;
SizingColX := GetColCoord(SizingCol);
end else
if (Cursor = crSmallCross) then
begin
ForceHideCaret;
SmallBoxArea := FSelectArea;
end else
if (Cursor = crLeftTop) then
begin
FRow := 0;
FCol := 0;
BuffString := '';
EnsureVisible(0, 0);
FCol2 := ColCount-1;
FRow2 := FRowCount-1;
SetSelectArea(Rect(0, 0, ColCount-1, FRowCount-1));
ColRowChanged;
end else
if (Cursor = crRight) then
begin
FRow := GetRowFromY(Y);
FCol := 0;
LastHover := FRow;
BuffString := '';
EnsureVisible(FCol, FRow);
FCol2 := ColCount-1;
FRow2 := FRow;
SmallBoxPos := 2;
AdjustSelection(Rect(0, FRow, ColCount-1, FRow), True);
ColRowChanged;
if Assigned(OnGutterClick)
then FOnGutterClick(Self, FRow, Button, Shift);
end else
if (Cursor = crDown) then
begin
FCol := GetColFromX(X);
FRow := 0;
LastHover := FCol;
BuffString := '';
EnsureVisible(FCol, FRow);
FCol2 := FCol;
FRow2 := FRowCount-1;
SmallBoxPos := 1;
AdjustSelection(Rect(FCol, 0, FCol, FRowCount-1), True);
ColRowChanged;
if Assigned(FOnHeaderClick)
then FOnHeaderClick(Self, FCol, Button, Shift);
end else
if (Cursor = crPlus) then
begin
BuffString := '';
Pt := GetCellAtPos(X, Y);
if (Pt.X = FCol) and (Pt.Y = FRow) then
begin
EnsureVisible(FCol, FRow);
if (not FReadOnly) and (not FColumns[FCol].FReadOnly) then
begin
IsEditing := True;
FEdit.ShowEdit(FCol, FRow);
end;
end else
if (Pt.X <> -1) and (pt.Y <> -1) then
begin
EnsureVisible(Pt.X, Pt.Y);
FCol := Pt.X;
FRow := Pt.Y;
BuffString := '';
FCol2 := FCol;
FRow2 := FRow;
SetSelectArea(Rect(FCol, FRow, FCol, FRow));
end;
ColRowChanged;
end;
*)
SetCapture(Handle);
SetFocus;
inherited;
end;
procedure TNiceGrid.MouseMove(Shift: TShiftState; X, Y: Integer);
var
Total2Col: Integer;
Suggested: Integer;
Pt: TPoint;
l, t, r, b: Integer;
i: Integer;
begin
if not FEnabled then
begin
FGridState := gsNormal;
Cursor := crDefault;
inherited;
Exit;
end;
if (ssLeft in Shift) then
begin
case FGridState of
gsCell:
begin
Pt := GetCellAtPos(X, Y);
if (Pt.X <> -1) and (Pt.Y <> -1) then
begin
l := Min(Pt.X, FCol);
t := Min(Pt.Y, FRow);
r := Max(Pt.X, FCol);
b := Max(Pt.Y, FRow);
FCol2 := Pt.X;
FRow2 := Pt.Y;
SetSelectArea(Rect(l, t, r, b));
EnsureVisible(FCol2, FRow2);
end;
end;
gsBoxDrag:
begin
Pt := GetCellAtPos(X, Y);
if (Pt.X <> -1) and (Pt.Y <> -1) then
begin
l := Min(Pt.X, SmallBoxArea.Left);
t := Min(Pt.Y, SmallBoxArea.Top);
r := Max(Pt.X, SmallBoxArea.Right);
b := Max(Pt.Y, SmallBoxArea.Bottom);
FCol2 := Pt.X;
FRow2 := Pt.Y;
SetSelectArea(Rect(l, t, r, b));
EnsureVisible(FCol2, FRow2);
end;
end;
gsSelRow:
begin
i := GetRowFromY(Y);
if (i <> -1) and (i <> LastHover) then
begin
LastHover := i;
t := Min(i, FRow);
b := Max(i, FRow);
FRow2 := i;
SmallBoxPos := 2;
AdjustSelection(Rect(0, t, ColCount-1, b), True);
end;
end;
gsSelCol:
begin
i := GetColFromX(X);
if (i <> -1) and (i <> LastHover) then
begin
LastHover := i;
l := Min(i, FCol);
r := Max(i, FCol);
FCol2 := i;
SmallBoxPos := 1;
AdjustSelection(Rect(l, 0, r, FRowCount-1), True);
end;
end;
gsColSize:
begin
Suggested := Max(5, X + FHorzOffset - SizingColX - FixedWidth);
if FFitToWidth then
begin
if (SizingCol = ColCount-1) or (SizingCol = -1) then
begin
inherited;
Exit;
end;
Total2Col := (ClientWidth - FixedWidth) - (TotalWidth - Columns[SizingCol].FWidth - Columns[SizingCol+1].FWidth);
if (Total2Col > 10) then
begin
Columns[SizingCol].FWidth := Suggested;
Columns[SizingCol+1].FWidth := Total2Col - Suggested;
end;
if (Columns[SizingCol+1].FWidth < 5) then
begin
Columns[SizingCol].FWidth := Total2Col - 5;
Columns[SizingCol+1].FWidth := 5;
end;
end else
begin
Columns[SizingCol].FWidth := Suggested;
end;
Recalculate;
InvalidateRightWard(FixedWidth);
end;
end;
(*
if (Cursor = crPlus) then
begin
Pt := GetCellAtPos(X, Y);
if (Pt.X <> -1) and (Pt.Y <> -1) then
begin
l := Min(Pt.X, FCol);
t := Min(Pt.Y, FRow);
r := Max(Pt.X, FCol);
b := Max(Pt.Y, FRow);
FCol2 := Pt.X;
FRow2 := Pt.Y;
SetSelectArea(Rect(l, t, r, b));
EnsureVisible(FCol2, FRow2);
end;
end else
if (Cursor = crSmallCross) then
begin
Pt := GetCellAtPos(X, Y);
if (Pt.X <> -1) and (Pt.Y <> -1) then
begin
l := Min(Pt.X, SmallBoxArea.Left);
t := Min(Pt.Y, SmallBoxArea.Top);
r := Max(Pt.X, SmallBoxArea.Right);
b := Max(Pt.Y, SmallBoxArea.Bottom);
FCol2 := Pt.X;
FRow2 := Pt.Y;
SetSelectArea(Rect(l, t, r, b));
EnsureVisible(FCol2, FRow2);
end;
end else
if (Cursor = crRight) then
begin
i := GetRowFromY(Y);
if (i <> -1) and (i <> LastHover) then
begin
LastHover := i;
t := Min(i, FRow);
b := Max(i, FRow);
FRow2 := i;
SmallBoxPos := 2;
AdjustSelection(Rect(0, t, ColCount-1, b), True);
end;
end else
if (Cursor = crDown) then
begin
i := GetColFromX(X);
if (i <> -1) and (i <> LastHover) then
begin
LastHover := i;
l := Min(i, FCol);
r := Max(i, FCol);
FCol2 := i;
SmallBoxPos := 1;
AdjustSelection(Rect(l, 0, r, FRowCount-1), True);
end;
end else
if (Cursor = crHSplit) then
begin
Suggested := Max(5, X + FHorzOffset - SizingColX - FixedWidth);
if FFitToWidth then
begin
if (SizingCol = ColCount-1) or (SizingCol = -1) then
begin
inherited;
Exit;
end;
Total2Col := (ClientWidth - FixedWidth) - (TotalWidth - Columns[SizingCol].FWidth - Columns[SizingCol+1].FWidth);
if (Total2Col > 10) then
begin
Columns[SizingCol].FWidth := Suggested;
Columns[SizingCol+1].FWidth := Total2Col - Suggested;
end;
if (Columns[SizingCol+1].FWidth < 5) then
begin
Columns[SizingCol].FWidth := Total2Col - 5;
Columns[SizingCol+1].FWidth := 5;
end;
end else
begin
Columns[SizingCol].FWidth := Suggested;
end;
Recalculate;
InvalidateRightWard(FixedWidth);
end; *)
end else
begin
Cursor := CursorArray[GetHitTestInfo(X, Y)];
FGridState := GridStateArray[GetHitTestInfo(X, Y)];
end;
inherited;
end;
procedure TNiceGrid.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
Y: Integer);
var
Ls: TList;
ax, ay: Integer;
l, t, w, h: Integer;
function GetCopy(nx, ny: Integer): string;
var
ix, iy: Integer;
begin
ix := nx;
iy := ny;
while (ix < l)
do ix := ix + w;
while (iy < t)
do iy := iy + h;
ix := ((ix - l) mod w) + l;
iy := ((iy - t) mod h) + t;
Result := SafeGetCell(TNiceColumn(Ls[ix]).Index, iy);
end;
begin
if (Cursor = crSmallCross) then
begin
if FReadOnly then
begin
SmallBoxArea := Rect(-1, -1, -1, -1);
InvalidateCells;
end else
begin
FUpdating := True;
Ls := TList.Create;
for ax := FSelectArea.Left to FSelectArea.Right do
if FColumns[ax].FVisible
then Ls.Add(FColumns[ax]);
l := 0;
for ax := 0 to Ls.Count-1 do
begin
if (TNiceColumn(Ls[ax]).Index = SmallBoxArea.Left) then
begin
l := ax;
Break;
end;
end;
t := SmallBoxArea.Top;
w := (SmallBoxArea.Right - SmallBoxArea.Left) + 1;
h := (SmallBoxArea.Bottom - SmallBoxArea.Top) + 1;
for ax := 0 to Ls.Count-1 do
for ay := FSelectArea.Top to FSelectArea.Bottom
do InternalSetCell(TNiceColumn(Ls[ax]).Index, ay, GetCopy(ax, ay), True);
Ls.Free;
SmallBoxArea := Rect(-1, -1, -1, -1);
BuffString := '';
FUpdating := False;
InvalidateCells;
end;
end;
Cursor := CursorArray[GetHitTestInfo(X, Y)];
FGridState := GridStateArray[GetHitTestInfo(X, Y)];
ReleaseCapture;
LastHover := -1;
inherited;
end;
procedure TNiceGrid.SetColumns(Value: TNiceColumns);
begin
FColumns.Assign(Value);
end;
function TNiceGrid.CreateColumn: TNiceColumn;
begin
Result := TNiceColumn.Create(Columns);
end;
procedure TNiceGrid.UpdateColumn(Index: Integer);
var
l, w: Integer;
Rc: TRect;
begin
l := GetColCoord(Index);
w := FColumns[Index].FWidth;
Rc := Rect(l - 3, 0, l + w + 3, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.UpdateColumns;
begin
UpdateHeader;
Invalidate;
end;
function TNiceGrid.GetColCount: Integer;
begin
Result := FColumns.Count;
end;
function TNiceGrid.TotalWidth: Integer;
var
x: Integer;
begin
Result := 0;
for x := 0 to FColumns.Count-1 do
begin
if FColumns[x].FVisible
then Result := Result + FColumns[x].FWidth;
end;
end;
procedure TNiceGrid.CMFontChanged(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
var
x: Integer;
begin
inherited;
for x := 0 to FColumns.Count-1
do FColumns[x].Font.Assign(Font);
end;
procedure TNiceGrid.WMSize(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin
inherited;
Recalculate;
if (FColumns.Count > 0)
then EnsureVisible(FCol, FRow);
end;
procedure TNiceGrid.WMEraseBkgnd(var Msg: {$IFDEF FPC}TLMEraseBkGnd{$ELSE}TWMEraseBkGnd{$ENDIF});
begin
Msg.Result := 1;
end;
procedure TNiceGrid.CMWantSpecialKey(var Message: {$IFDEF FPC}TLMKey{$ELSE}TWMKey{$ENDIF});
begin
inherited;
with Message do
case CharCode of
VK_LEFT, VK_UP, VK_RIGHT, VK_DOWN:
Result := 1;
end;
end;
procedure TNiceGrid.SetShowGrid(Value: Boolean);
begin
if (FShowGrid <> Value) then
begin
FShowGrid := Value;
InvalidateCells;
end;
end;
procedure TNiceGrid.SetShowFooter(const Value: Boolean);
begin
if (FShowFooter <> Value) then
begin
FShowFooter := Value;
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.Clear;
var
x: Integer;
begin
for x := 0 to ColCount-1
do FColumns[x].FStrings.Clear;
InvalidateCells;
end;
procedure TNiceGrid.SetHorzOffset(Value: Integer);
begin
if (FHorzOffset <> Value) then
begin
FHorzOffset := Max(0, Min(FMaxHScroll, Value));
SetScrollBar(SB_HORZ, 0, FHorzOffset, SIF_POS);
InvalidateRightWard(FixedWidth);
end;
end;
procedure TNiceGrid.SetVertOffset(Value: Integer);
begin
if (FVertOffset <> Value) then
begin
FVertOffset := Max(0, Min(FMaxVScroll, Value));
NormalizeVertOffset;
SetScrollBar(SB_VERT, 0, FVertOffset, SIF_POS);
InvalidateDownWard(FixedHeight);
end;
end;
procedure TNiceGrid.EnsureVisible(X, Y: Integer);
var
t, b, h: Integer;
l, r: Integer;
Horz, Vert: Boolean;
SuggestedHorz, SuggestedVert: Integer;
begin
if (X = -1) or (Y = -1)
then Exit;
if (AllWidth < ClientWidth) and (AllHeight < ClientHeight)
then Exit;
SuggestedVert := FVertOffset;
t := FVertOffset div FDefRowHeight;
h := ((ClientHeight - FixedHeight) div FDefRowHeight) - 1;
if FShowFooter
then h := h-1;
b := t + h;
Vert := (Y < t) or (Y > b);
if (Y < t)
then SuggestedVert := Y * FDefRowHeight;
if (Y > b)
then SuggestedVert := (Y - h) * FDefRowHeight;
SuggestedHorz := FHorzOffset;
l := GetColCoord(X) - FHorzOffset + FixedWidth;
r := l + FColumns[x].FWidth;
Horz := (l < FixedWidth) or (r > ClientWidth);
if (l < FixedWidth)
then SuggestedHorz := Max(0, SuggestedHorz + (l - FixedWidth));
if (r > ClientWidth)
then SuggestedHorz := Min(FMaxHScroll, SuggestedHorz - (ClientWidth - r) + 1);
if Vert and not Horz
then SetVertOffset(SuggestedVert) else
if Horz and not Vert
then SetHorzOffset(SuggestedHorz) else
if Horz and Vert
then
begin
FHorzOffset := SuggestedHorz;
FVertOffset := SuggestedVert;
SetScrollBar(SB_HORZ, 0, FHorzOffset, SIF_POS);
SetScrollBar(SB_VERT, 0, FVertOffset, SIF_POS);
Invalidate;
end;
end;
function TNiceGrid.HeaderCells(I: Integer): THeaderInfo;
begin
Result := PHeaderInfo(FHeaderInfos[I])^;
end;
function TNiceGrid.HeaderCellsCount: Integer;
begin
Result := FHeaderInfos.Count;
end;
procedure TNiceGrid.SetReadOnly(Value: Boolean);
begin
if (FReadOnly <> Value) then
begin
FReadOnly := Value;
end;
end;
procedure TNiceGrid.SetCol(Value: Integer);
begin
if (FCol <> Value) then
begin
ForceHideCaret;
FCol := Value;
FCol2 := Value;
FRow2 := FRow;
BuffString := '';
SetSelectArea(Rect(FCol, FRow, FCol, FRow));
InvalidateRightWard(FixedWidth);
ColRowChanged;
end;
end;
procedure TNiceGrid.SetRow(Value: Integer);
begin
if (FRow <> Value) then
begin
ForceHideCaret;
FRow := Value;
FRow2 := Value;
FCol2 := FCol;
BuffString := '';
SetSelectArea(Rect(FCol, FRow, FCol, FRow));
InvalidateDownWard(FixedHeight);
ColRowChanged;
end;
end;
procedure TNiceGrid.AdjustSelection(Value: TRect; Force: Boolean);
var
Old, Rc: TRect;
R1, R2, R: TRect;
begin
if EqualRect(FSelectArea, Value) and not Force
then Exit;
ForceHideCaret;
Old := FSelectArea;
FSelectArea := Value;
Rc.Left := Min(Old.Left, FSelectArea.Left);
Rc.Top := Min(Old.Top, FSelectArea.Top);
Rc.Right := Max(Old.Right, FselectArea.Right);
Rc.Bottom := Max(Old.Bottom, FSelectArea.Bottom);
R1 := GetCellRect(Rc.Left, Rc.Top);
R2 := GetCellRect(Rc.Right, Rc.Bottom);
R := Rect(R1.Left, R1.Top, R2.Right, R2.Bottom);
OffsetRect(R, - FHorzOffset + FixedWidth, - FVertOffset + FixedHeight);
InflateRect(R, 3, 3);
InvalidateRect(Handle, @R, False);
if (FGutterKind = gkPointer) then
begin
R := Rect(0, FixedHeight, FixedWidth, ClientHeight);
InvalidateRect(Handle, @R, False);
end;
end;
procedure TNiceGrid.SetSelectArea(Value: TRect);
begin
AdjustSelection(Value, False);
end;
var
CaretVisible: Boolean = False;
// I don't think MS's HideCaret and ShowCaret mechanism was a good idea.
procedure TNiceGrid.ForceHideCaret;
begin
if CaretVisible
then HideCaret(Handle);
CaretVisible := False;
FEdit.HideEdit;
end;
procedure TNiceGrid.ForceShowCaret;
begin
if not CaretVisible
then ShowCaret(Handle);
CaretVisible := True;
end;
procedure TNiceGrid.WMKillFocus(var Msg: {$IFDEF FPC}TLMKillFocus{$ELSE}TWMKillFocus{$ENDIF});
begin
if FEdit.HandleAllocated then
begin
if (Msg.FocusedWnd <> FEdit.Handle)
then ForceHideCaret;
DestroyCaret{$IFDEF FPC}(FEdit.Handle){$ENDIF};
end;
CaretVisible := False;
if not IsEditing
then InvalidateCells;
end;
procedure TNiceGrid.WMSetFocus(var Msg: {$IFDEF FPC}TLMSetFocus{$ELSE}TWMSetFocus{$ENDIF});
begin
Unused(Msg);
CreateCaret(Handle, 0, 1, FDefRowHeight - 2);
CaretVisible := False;
InvalidateCells;
end;
procedure TNiceGrid.SetGutterKind(Value: TGutterKind);
var
Rc: TRect;
RedrawAll: Boolean;
Old: TGutterKind;
begin
Old := FGutterKind;
if (FGutterKind <> Value) then
begin
FGutterKind := Value;
Recalculate;
RedrawAll := (Old = gkNone) or (Value = gkNone);
if RedrawAll then
begin
Invalidate;
end else
begin
Rc := Rect(0, FixedHeight, FixedWidth, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
end;
end;
procedure TNiceGrid.SetGutterWidth(Value: Integer);
begin
if (FGutterWidth <> Value) then
begin
FGutterWidth := Value;
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.CopyToClipboard;
var
s: string;
t: TStringList;
x, y: Integer;
begin
t := TStringList.Create;
for y := FSelectArea.Top to FSelectArea.Bottom do
begin
s := '';
for x := FSelectArea.Left to FSelectArea.Right do
begin
if FColumns[x].FVisible then
begin
if (x = FSelectArea.Left)
then s := SafeGetCell(X, Y)
else s := s + #9 + SafeGetCell(X, Y);
end;
end;
t.Add(s);
end;
Clipboard.AsText := t.Text;
t.Free;
end;
procedure TNiceGrid.CutToClipboard;
var
s: string;
t: TStringList;
x, y: Integer;
begin
FUpdating := True;
t := TStringList.Create;
for y := FSelectArea.Top to FSelectArea.Bottom do
begin
s := '';
for x := FSelectArea.Left to FSelectArea.Right do
begin
if FColumns[x].FVisible then
begin
if (x = FSelectArea.Left)
then s := SafeGetCell(X, Y)
else s := s + #9 + SafeGetCell(X, Y);
InternalSetCell(X, Y, '', True);
end;
end;
t.Add(s);
end;
Clipboard.AsText := t.Text;
t.Free;
FUpdating := False;
InvalidateCells;
end;
procedure TNiceGrid.PasteFromClipboard;
var
tr, tc: TStringList;
x, y: Integer;
s: string;
n: Integer;
TabCnt: Integer;
ax, ay: Integer;
ColCnt: Integer;
begin
if not Clipboard.HasFormat(CF_TEXT)
then Exit;
ForceHideCaret;
FUpdating := True;
tr := TStringList.Create;
tc := TStringList.Create;
tr.Text := Clipboard.AsText;
TabCnt := 1;
for y := 0 to tr.Count-1 do
begin
n := 1;
s := tr[y];
for x := 1 to Length(s) do
if (s[x] = #9)
then Inc(n);
TabCnt := Max(TabCnt, n);
end;
ColCnt := ColCount; // Just to make it fast
if (FSelectArea.Left = FSelectArea.Right) and (FSelectArea.Top = FSelectArea.Bottom) then
begin
for y := 0 to tr.Count-1 do
begin
tc.Text := StringReplace(tr[y], #9, #13#10, [rfReplaceAll]);
while (tc.Count < TabCnt)
do tc.Add('');
x := 0;
ax := FCol;
while (x < tc.Count) do
begin
ay := FRow + y;
if FColumns[ax].FVisible then
begin
if (ax < ColCnt) and (ay < FRowCount)
then InternalSetCell(ax, ay, tc[x], True);
Inc(x);
end;
Inc(ax);
end;
end;
end else
begin
ay := FSelectArea.Top;
while (ay <= FSelectArea.Bottom) do
begin
tc.Text := StringReplace(tr[(ay - FSelectArea.Top) mod tr.Count], #9, #13#10, [rfReplaceAll]);
while (tc.Count < TabCnt)
do tc.Add('');
ax := FSelectArea.Left;
x := 0;
while (ax <= FSelectArea.Right) do
begin
if FColumns[ax].FVisible then
begin
InternalSetCell(ax, ay, tc[x], True);
Inc(x);
if (x = tc.Count)
then x := 0;
end;
Inc(ax);
end;
Inc(ay);
end;
end;
tr.Free;
tc.Free;
FUpdating := False;
InvalidateCells;
end;
procedure TNiceGrid.InvalidateCells;
var
Rc: TRect;
begin
Rc := Rect(FixedWidth-2, FixedHeight-2, ClientWidth, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.InvalidateDownWard(Top: Integer);
var
Rc: TRect;
begin
Rc := Rect(0, Top, ClientWidth, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.InvalidateRightWard(Left: Integer);
var
Rc: TRect;
begin
Rc := Rect(Left, 0, ClientWidth, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.NormalizeVertOffset;
begin
FVertOffset := (FVertOffset div FDefRowHeight) * FDefRowHeight;
end;
procedure TNiceGrid.SetGutterFont(Value: TFont);
begin
FGutterFont.Assign(Value);
InvalidateGutter;
end;
procedure TNiceGrid.SetHeaderFont(Value: TFont);
begin
FHeaderFont.Assign(Value);
InvalidateHeader;
end;
procedure TNiceGrid.SetFooterFont(const Value: TFont);
begin
FFooterFont.Assign(Value);
Invalidate;
end;
procedure TNiceGrid.InvalidateGutter;
var
Rc: TRect;
begin
Rc := Rect(0, FixedHeight, FixedWidth, ClientHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.InvalidateHeader;
var
Rc: TRect;
begin
Rc := Rect(0, 0, ClientWidth, FixedHeight);
InvalidateRect(Handle, @Rc, False);
end;
procedure TNiceGrid.HeaderFontChange(Sender: TObject);
begin
InvalidateHeader;
end;
procedure TNiceGrid.GutterFontChange(Sender: TObject);
begin
InvalidateGutter;
end;
procedure TNiceGrid.FooterFontChange(Sender: TObject);
begin
Invalidate;
end;
function TNiceGrid.GetFirstVisible: Integer;
var
x: Integer;
begin
Result := -1;
if (ColCount > 0) then
begin
for x := 0 to ColCount-1 do
begin
if Columns[x].Visible then
begin
Result := x;
Break;
end;
end;
end;
end;
function TNiceGrid.GetLastVisible: Integer;
var
x: Integer;
begin
Result := -1;
if (ColCount > 0) then
begin
for x := ColCount-1 downto 0 do
begin
if Columns[x].Visible then
begin
Result := x;
Break;
end;
end;
end;
end;
function TNiceGrid.GetNextVisible(Index: Integer): Integer;
var
x: Integer;
begin
Result := Index;
if (ColCount > 0) and (Index < ColCount) then
begin
for x := (Index + 1) to (ColCount - 1) do
begin
if Columns[x].Visible then
begin
Result := x;
Break;
end;
end;
end;
end;
function TNiceGrid.GetPrevVisible(Index: Integer): Integer;
var
x: Integer;
begin
Result := Index;
if (ColCount > 0) and (Index > 0) then
begin
for x := (Index - 1) downto 0 do
begin
if Columns[x].Visible then
begin
Result := x;
Break;
end;
end;
end;
end;
procedure TNiceGrid.DeleteRow(ARow: Integer);
var
x, y: Integer;
begin
ForceHideCaret;
if (ARow >= 0) and (ARow < FRowCount) then
begin
for x := 0 to ColCount-1 do
begin
with FColumns[x].Strings do
begin
if (Count > ARow) then
begin
for y := ARow to Count-2
do Strings[y] := Strings[y + 1];
Strings[Count-1] := '';
end;
end;
end;
if (FRow = FRowCount-1)
then Dec(FRow);
RowCount := RowCount - 1;
end;
end;
procedure TNiceGrid.InsertRow(ARow: Integer);
var
x: Integer;
begin
ForceHideCaret;
if (ARow >= 0) and (ARow < FRowCount) then
begin
for x := 0 to ColCount-1 do
begin
with FColumns[x].Strings do
begin
while (Count < ARow)
do Add('');
Insert(ARow, '');
end;
end;
RowCount := RowCount + 1;
end;
end;
function TNiceGrid.AddRow: Integer;
var
x: Integer;
n: Integer;
begin
ForceHideCaret;
n := FRowCount + 1;
for x := 0 to ColCount-1 do
begin
with FColumns[x].Strings do
begin
while (Count < n)
do Add('');
Strings[FRowCount] := '';
end;
end;
RowCount := RowCount + 1;
Result := FRowCount-1;
end;
// This is a workaround to avoid mess up with accelerators.
// NiceGrid was unable to capture keyboard event of chars that already
// defined as accelerator of another control.
// (Char after '&' (ampersand) in ex. TButton.Caption, TMenuItem.Caption, etc.)
// Don't know why and how this workaround works, but this is found after
// spying with WinSight. WM_USER + $B902 - mPri-
procedure TNiceGrid.WMUnknown(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TMessage{$ENDIF});
begin
Msg.Result := 0;
end;
procedure TNiceGrid.WMMouseWheel(var Msg: {$IFDEF FPC}TLMessage{$ELSE}TWMMouseWheel{$ENDIF});
var
Old: Integer;
begin
Old := FVertOffset;
FVertOffset := Max(0, Min(FMaxVScroll, FVertOffset - Msg.{$IFDEF FPC}lParam{$ELSE}WheelDelta{$ENDIF}));
if (FVertOffset <> Old) then
begin
SetScrollBar(SB_VERT, 0, FVertOffset, SIF_POS);
Invalidate;
end;
end;
procedure TNiceGrid.ColRowChanged;
begin
if Assigned(Sync)
then Sync.Row := FRow;
if Assigned(FOnColRowChanged)
then FOnColRowChanged(Self, FCol, FRow);
end;
procedure TNiceGrid.Notification(AComponent: TComponent;
Operation: TOperation);
begin
if (AComponent = Sync) and (Operation = opRemove)
then Sync := nil;
inherited;
end;
procedure TNiceGrid.SetGutterStrings(const Value: TStrings);
begin
FGutterStrings.Assign(Value);
if (FGutterKind = gkString)
then InvalidateGutter;
end;
function TNiceGrid.GetObject(X, Y: Integer): TObject;
var
t: TStrings;
begin
Result := nil;
if (X > ColCount-1) or (Y > FRowCount-1)
then raise Exception.Create('Cell Index out of bound.');
t := Columns[X].FStrings;
if (Y < t.Count)
then Result := t.Objects[Y];
end;
procedure TNiceGrid.SetObject(X, Y: Integer; const Value: TObject);
var
t: TStrings;
begin
if (X > ColCount-1) or (Y > FRowCount-1)
then raise Exception.Create('Cell Index out of bound.');
t := Columns[X].FStrings;
while (Y > t.Count-1)
do t.Add('');
t.Objects[Y] := Value;
end;
procedure TNiceGrid.ClearMergeCells;
var
x, y: Integer;
List: TStrings;
begin
for x := 0 to FColumns.Count-1 do
begin
List := FColumns[x].FStrings;
for y := 0 to List.Count-1
do List.Objects[y] := nil;
end;
for x := 0 to Mergeds.Count-1
do TMergeCell(Mergeds[x]).Free;
Mergeds.Clear;
end;
function TNiceGrid.MergeCells(const X1, Y1, X2, Y2: Integer;
ACaption: string): TMergeCell;
begin
Result := TMergeCell.Create;
Result.Font.Assign(Font);
Result.Color := Color;
Result.Caption := ACaption;
Result.HorzAlign := haCenter;
Result.VertAlign := vaCenter;
Result.Rc := Rect(Min(X1, X2), Min(Y1, Y2), Max(X1, X2), Max(Y1, Y2));
Mergeds.Add(Result);
if not FUpdating then
begin
Recalculate;
Invalidate;
end;
end;
procedure TNiceGrid.BuildMergeData;
var
Rc: TRect;
x, y, z: Integer;
begin
for x := 0 to Mergeds.Count-1 do
begin
Rc := TMergeCell(Mergeds[x]).Rc;
for y := Rc.Left to Rc.Right do
begin
if (y >= FColumns.Count)
then Continue;
for z := Rc.Top to Rc.Bottom do
begin
InternalSetCell(y, z, '', False);
SetObject(y, z, TObject(MergeID));
end;
end;
end;
end;
procedure TNiceGrid.DrawMergedCell(Index: Integer);
var
Data: TMergeCell;
Rc, Dummy: TRect;
l1, l2, t, h: Integer;
begin
Data := TMergeCell(Mergeds[Index]);
l1 := GetColCoord(Data.Rc.Left);
l2 := GetColCoord(Data.Rc.Right + 1);
t := FDefRowHeight * Data.Rc.Top;
h := FDefRowHeight * (Data.Rc.Bottom - Data.Rc.Top + 1);
Rc := Rect(l1-1, t-1, l2, t+h);
OffsetRect(Rc, -FHorzOffset + FixedWidth, -FVertOffset + FixedHeight);
Dummy := Rect(0, 0, 0, 0); // to silence the compiler
if IntersectRect(Dummy, Rc, CellBox) then
begin
with Canvas do
begin
Font.Assign(Data.Font);
if not FEnabled
then Font.Color := FGridColor;
Pen.Color := FGridColor;
Brush.Color := Data.Color;
Brush.Style := bsSolid;
if FShowGrid
then Rectangle(Rc)
else FillRect(Rc);
Brush.Style := bsClear;
InflateRect(Rc, -4, -2);
DrawString(Canvas, Data.Caption, Rc, Data.HorzAlign, Data.VertAlign, False);
end;
end;
end;
function TNiceGrid.GetHeaderInfo: TList;
begin
Result := FHeaderInfos;
end;
function TNiceGrid.GetMergedCellsData: TList;
begin
Result := Mergeds;
end;
procedure TNiceGrid.SetEnabled(const Value: Boolean);
begin
if (FEnabled <> Value) then
begin
FEnabled := Value;
Invalidate;
end;
end;
{$IFDEF FPC}
// Handle Lazarus' High-DPI scaling
procedure TNiceGrid.DoAutoAdjustLayout(const AMode: TLayoutAdjustmentPolicy;
const AXProportion, AYProportion: Double);
var
i: Integer;
col: TNiceColumn;
begin
inherited DoAutoAdjustLayout(AMode, AXProportion, AYProportion);
if AMode in [lapAutoAdjustWithoutHorizontalScrolling, lapAutoAdjustForDPI] then
begin
FDefColWidth := round(FDefColWidth * AYProportion);
FDefRowHeight := round(FDefRowHeight * AYProportion);
FGutterWidth := round(FGutterWidth * AXProportion);
for i := 0 to Columns.Count-1 do
begin
col := Columns[i];
col.Width := round(col.Width * AXProportion);
end;
end;
end;
procedure TNiceGrid.FixDesignFontsPPI(const ADesignTimePPI: Integer);
var
i: Integer;
col: TNiceColumn;
begin
inherited;
DoFixDesignFontPPI(FHeaderFont, ADesignTimePPI);
DoFixDesignFontPPI(FGutterFont, ADesignTimePPI);
DoFixDesignFontPPI(FFooterFont, ADesignTimePPI);
for i := 0 to Columns.Count-1 do
begin
col := Columns[i];
DoFixDesignFontPPI(col.Font, ADesignTimePPI);
end;
end;
procedure TNiceGrid.ScaleFontsPPI(const AToPPI: Integer; const AProportion: Double);
var
i: Integer;
col: TNiceColumn;
begin
inherited;
DoScaleFontPPI(FHeaderFont, AToPPI, AProportion);
DoScaleFontPPI(FGutterFont, AToPPI, AProportion);
DoScaleFontPPI(FFooterFont, AToPPI, AProportion);
for i := 0 to Columns.Count-1 do
begin
col := Columns[i];
DoScaleFontPPI(col.Font, AToPPI, AProportion);
end;
end;
{$ENDIF}
{ TNiceColumn }
constructor TNiceColumn.Create(Collection: TCollection);
begin
FStrings := TStringList.Create;
FFont := TFont.Create;
FHorzAlign := haLeft;
FVertAlign := vaCenter;
FVisible := True;
FCanResize := True;
FReadOnly := False;
FTag := 0;
FTag2 := 0;
with TNiceColumns(Collection).Grid do
begin
Self.FFont.Assign(Font);
Self.FWidth := DefColWidth;
Self.FColor := Color;
end;
FFont.OnChange := FontChange;
inherited Create(Collection);
end;
destructor TNiceColumn.Destroy;
begin
inherited Destroy;
FFont.Free;
FStrings.Free;
end;
procedure TNiceColumn.Assign(Source: TPersistent);
begin
if (Source is TNiceColumn) then
begin
Title := TNiceColumn(Source).Title;
Footer := TNiceColumn(Source).Footer;
Width := TNiceColumn(Source).Width;
Font := TNiceColumn(Source).Font;
Color := TNiceColumn(Source).Color;
HorzAlign := TNiceColumn(Source).HorzAlign;
VertAlign := TNiceColumn(Source).VertAlign;
Visible := TNiceColumn(Source).Visible;
Tag := TNiceColumn(Source).Tag;
Tag2 := TNiceColumn(Source).Tag2;
Hint := TNiceColumn(Source).Hint;
CanResize := TNiceColumn(Source).CanResize;
ReadOnly := TNiceColumn(Source).ReadOnly;
Strings.Assign(TNiceColumn(Source).Strings);
Changed(False);
end;
end;
procedure TNiceColumn.SetColor(Value: TColor);
begin
if (FColor <> Value) then
begin
FColor := Value;
Changed(False);
end;
end;
procedure TNiceColumn.SetFont(Value: TFont);
begin
FFont.Assign(Value);
Changed(False);
end;
procedure TNiceColumn.SetHorzAlign(Value: THorzAlign);
begin
if (FHorzAlign <> Value) then
begin
FHorzAlign := Value;
Changed(False);
end;
end;
procedure TNiceColumn.SetTitle(Value: string);
begin
if (FTitle <> Value) then
begin
FTitle := Value;
Changed(True);
end;
end;
procedure TNiceColumn.SetFooter(const Value: string);
begin
if (FFooter <> Value) then
begin
FFooter := Value;
Changed(False);
end;
end;
procedure TNiceColumn.SetVertAlign(Value: TVertAlign);
begin
if (FVertAlign <> Value) then
begin
FVertAlign := Value;
Changed(False);
end;
end;
procedure TNiceColumn.SetWidth(Value: Integer);
begin
if (FWidth <> Value) then
begin
FWidth := Value;
Changed(True);
end;
end;
procedure TNiceColumn.SetVisible(Value: Boolean);
begin
if (FVisible <> Value) then
begin
FVisible := Value;
TNiceColumns(Collection).FGrid.ForcedColumn := Index;
Changed(True);
end;
end;
procedure TNiceColumn.SetStrings(Value: TStrings);
begin
FStrings.Assign(Value);
Changed(False);
end;
procedure TNiceColumn.FontChange(Sender: TObject);
begin
Changed(False);
end;
function TNiceColumn.IsFontStored: Boolean;
begin
Result := True;
with TNiceColumns(Collection).FGrid.Font do
begin
if (Charset = FFont.Charset) and
(Color = FFont.Color) and
(Height = FFont.Height) and
(Name = FFont.Name) and
(Pitch = FFont.Pitch) and
(PixelsPerInch = FFont.PixelsPerInch) and
(Size = FFont.Size) and
(Style = FFont.Style)
then Result := False;
end;
end;
function TNiceColumn.GetGrid: TNiceGrid;
begin
Result := TNiceColumns(Collection).FGrid;
end;
function TNiceColumn.GetDisplayName: string;
begin
if (FTitle <> '')
then Result := FTitle
else Result := 'Column ' + IntToStr(Index);
end;
{ TNiceColumns }
constructor TNiceColumns.Create(AGrid: TNiceGrid);
begin
inherited Create(TNiceColumn);
FGrid := AGrid;
end;
function TNiceColumns.Add: TNiceColumn;
begin
Result := TNiceColumn(inherited Add);
end;
function TNiceColumns.GetItem(Index: Integer): TNiceColumn;
begin
Result := TNiceColumn(inherited GetItem(Index));
end;
procedure TNiceColumns.SetItem(Index: Integer; Value: TNiceColumn);
begin
inherited SetItem(Index, Value);
end;
function TNiceColumns.GetOwner: TPersistent;
begin
Result := FGrid;
end;
function TNiceColumns.Insert(Index: Integer): TNiceColumn;
begin
Result := AddItem(nil, Index);
end;
function TNiceColumns.AddItem(Item: TNiceColumn;
Index: Integer): TNiceColumn;
begin
if (Item = nil)
then Result := FGrid.CreateColumn
else
begin
Result := Item;
if Assigned(Item) then
begin
Result.Collection := Self;
if (Index < 0)
then Index := Count - 1;
Result.Index := Index;
end;
end;
end;
procedure TNiceColumns.Update(Item: TCollectionItem);
begin
if (Item <> nil)
then FGrid.UpdateColumn(Item.Index)
else FGrid.UpdateColumns;
end;
{ TAlignedEdit }
constructor TNiceInplace.Create(Grid: TNiceGrid);
begin
inherited Create(FGrid);
FGrid := Grid;
FAlignment := haLeft;
Parent := FGrid;
ParentColor := False;
BorderStyle := bsNone;
Left := -200;
Top := -200;
Visible := False;
end;
procedure TNiceInplace.CreateParams(var Params: TCreateParams);
const
Alignments: array [THorzAlign] of Cardinal = (ES_LEFT, ES_CENTER, ES_RIGHT);
begin
inherited CreateParams(Params);
Params.Style := Params.Style or Alignments[FAlignment];
end;
procedure TNiceInplace.SetAlignment(Value: THorzAlign);
begin
if (FAlignment <> Value) then
begin
FAlignment := Value;
RecreateWnd{$IFDEF FPC}(Self){$ENDIF};
end;
end;
procedure TNiceInplace.ShowEdit(X, Y: Integer);
var
Rc: TRect;
Column: TNiceColumn;
l, t, w, h: Integer;
begin
if CaretVisible
then HideCaret(Handle);
CaretVisible := False;
CellX := X;
CellY := Y;
Column := FGrid.FColumns[x];
Color := FGrid.GetCellColor(X, Y);
SetAlignment(Column.FHorzAlign);
Text := FGrid.SafeGetCell(X, Y);
Font.Assign(Column.FFont);
{$IFDEF FPC}
if Font.Height = 0 then
Font.Height := GetFontData(Font.Reference.Handle).Height;
{$ENDIF}
Rc := FGrid.GetCellRect(X, Y);
Rc := FGrid.CellRectToClient(Rc);
if (FAlignment = haRight)
then Rc.Right := Rc.Right + 1;
InflateRect(Rc, -4, -3);
l := Rc.Left;
w := Rc.Right - Rc.Left;
t := 0;
// h := FGrid.TextExtent('gM').CY;
h := FGrid.Canvas.TextHeight('gM');
case Column.FVertAlign of
vaTop: t := Rc.Top - 1;
vaCenter: t := Rc.Top + (((Rc.Bottom - Rc.Top) - h) div 2);
vaBottom: t := Rc.Bottom - h + 1;
end;
SetBounds(l, t, w, h);
Show;
end;
procedure TNiceInplace.HideEdit;
begin
if Visible
then Hide;
FGrid.IsEditing := False;
end;
procedure TNiceInplace.Change;
begin
inherited;
FGrid.InternalSetCell(CellX, CellY, Text, True);
end;
procedure TNiceInplace.KeyDown(var Key: Word; Shift: TShiftState);
begin
case Key of
VK_ESCAPE, VK_RETURN, VK_UP, VK_DOWN:
begin
HideEdit;
FGrid.SetFocus;
end;
else
inherited;
end;
end;
procedure TNiceInplace.KeyPress(var Key: Char);
var
Allowed: Boolean;
begin
Allowed := True;
if Assigned(FGrid.FOnFilterChar)
then FGrid.FOnFilterChar(Self, CellX, CellY, Key, Allowed);
if (not Allowed) and (Key <> Chr(VK_BACK))
then Key := Chr(0);
inherited;
end;
{ TNiceGridSync }
constructor TNiceGridSync.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOnDeleteRow := SyncDeleteRow;
FOnInsertRow := SyncInsertRow;
FOnColRowChanged := SyncColRow;
end;
procedure TNiceGridSync.Notification(AComponent: TComponent;
Operation: TOperation);
begin
if (AComponent = FGrid) and (Operation = opRemove)
then FGrid := nil;
inherited;
end;
procedure TNiceGridSync.SetGrid(const Value: TNiceGrid);
begin
if (FGrid <> Value) then
begin
FGrid := Value;
FGrid.Sync := Self;
FGrid.RowCount := RowCount;
end;
end;
procedure TNiceGridSync.SetScrollBar(AKind, AMax, APos, AMask: Integer);
begin
Unused(AMax);
if (AKind = SB_VERT) and Assigned(FGrid) then
begin
if ((AMask and SIF_POS) <> 0)
then FGrid.VertOffset := APos;
end;
end;
procedure TNiceGridSync.ShowHideScrollBar(HorzVisible,
VertVisible: Boolean);
begin
Unused(HorzVisible, VertVisible);
ShowScrollBar(Handle, SB_HORZ, True);
ShowScrollBar(Handle, SB_VERT, False);
EnableScrollBar(Handle, SB_HORZ, 3{ESB_DISABLE_BOTH});
end;
procedure TNiceGridSync.SyncColRow(Sender: TObject; ACol, ARow: Integer);
begin
Unused(ACol);
if Assigned(FGrid)
then FGrid.Row := ARow;
end;
procedure TNiceGridSync.SyncDeleteRow(Sender: TObject; ARow: Integer);
begin
if Assigned(FGrid)
then FGrid.DeleteRow(ARow);
end;
procedure TNiceGridSync.SyncInsertRow(Sender: TObject; ARow: Integer);
begin
if Assigned(FGrid) then
begin
if (ARow = FGrid.RowCount)
then FGrid.AddRow
else FGrid.InsertRow(ARow);
end;
end;
{ TMergeCell }
constructor TMergeCell.Create;
begin
inherited Create;
Font := TFont.Create;
end;
destructor TMergeCell.Destroy;
begin
Font.Free;
inherited Destroy;
end;
end.
Reference in New Issue View Git Blame Copy Permalink