Firemonkey Grid Control - Aligning a column to the right - delphi

I am using the FireMonkey Grid control but have an on-going issue in trying to right align a column. From other users postings, I have managed to create a new TColumn type, apply a style to this (text as HorzAlign=taTrailing) and in theory - thought that this would be solution. The values are provided by the OnGetValue function to the Grid control.
The problem is however that although at first it looks OK, if you scroll the bar/mouse wheel etc. the new TColumn type column does not appear to refresh correctly using the method/code below. It could be a bug/feature of the Grid (or the way I am doing it). I have tried .ReAlign etc...; but to no avail. The only way to get the grid back in line is do a column resize for example - which then redraws correctly?
The code below shows that it is a simple TGrid, with 2 cols, 1 the standard StringColumn and 1 my new StringColNum (wuth right alignment applied). - Any help appreciated as this one is a basic requirement of any grid work.
unit Unit1;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes, System.Variants,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Dialogs, FMX.Objects, FMX.Grid,
FMX.Layouts, FMX.Edit;
type
TForm1 = class(TForm)
Grid1: TGrid;
Button1: TButton;
StyleBook1: TStyleBook;
procedure Grid1GetValue(Sender: TObject; const Col, Row: Integer;
var Value: Variant);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TStringColNum = class(TStringColumn)
private
function CreateCellControl: TStyledControl; override;
public
constructor Create(AOwner: TComponent); override;
published
end;
var
Form1: TForm1;
implementation
{$R *.fmx}
constructor TStringColNum.Create(AOwner: TComponent);
begin
inherited;
end;
function TStringColNum.CreateCellControl: TStyledControl;
var
t:TEdit;
begin
Result:=TStringColNum.Create(Self);
Result.StyleLookup := 'textrightalign';
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Grid1.AddObject(TStringColumn.Create(Self));
Grid1.AddObject(TStringColNum.Create(Self)); // Right Aligned column?
Grid1.RowCount:=5000;
Grid1.ShowScrollBars:=True;
end;
procedure TForm1.Grid1GetValue(Sender: TObject; const Col, Row: Integer;
var Value: Variant);
var
cell: TStyledControl;
t: TText;
begin
if Col=0 then
Value:='Row '+IntToStr(Row);;
if Col=1 then
begin
cell := Grid1.Columns[Col].CellControlByRow(Row);
if Assigned(cell) then
begin
t := (Cell.FindStyleResource('text') as TText);
if Assigned(t) then
t.Text:='Row '+IntToStr(Row);
end;
end;
end;
end.
Kind regards. Ian.

All of which reminds me that I still haven't written my blog post about this.
Anyway, a grid cell can be any descendant of TStyledControl (basically any control). The default for a text cell is TTextCell, which is simply a TEdit. Being a TEdit means changing the alignment is really easy: just change the TextAlign property. No need to mess with styles (unless you really want to).
Your column needs to create your cells in the CreateCellControl method. You're actually creating an instance of your column which is your main problem.
You don't need the Create method for your column (it's doing nothing), so delete it (unless you need it for something else) and amend your CreateCellControl.
function TStringColNum.CreateCellControl: TStyledControl;
begin
Result:=inherited;
TTextCell(Result).TextAlign := taTrailing;
end;
Finally, your GetValue event handler needs do nothing more than return the value:
procedure TForm1.Grid1GetValue(Sender: TObject; const Col, Row: Integer;
var Value: Variant);
begin
if Col=0 then
Value:='Row '+IntToStr(Row);
if Col=1 then
Value := 'Row '+IntToStr(Row);
end;

I think it is a laziness of Embarcadero.
adding/modifying 3 lines in FMX.Grid.pas solves this problem.
instead of modifiying original FMX.Grid pas, I recommend copying original FMX.Grid pas to your Project directory, including in your Project (add to Project) and adding/modifiying following lines.
TColumn = class(TStyledControl)
private const
HorzTextMargin = 2;
VertTextMargin = 1;
private
FReadOnly: Boolean;
FHorizontalAlign:TTextAlign;//Add this Line *********
FEditMode: Integer;
FApplyImmediately: boolean;
...
...
procedure UpdateCell(ARow: Integer);
published
property HorizontalAlign: TTextAlign read FHorizontalAlign write FHorizontalAlign;//add this line *******
property Align;
property ClipChildren default False;
procedure TColumn.DefaultDrawCell(const Canvas: TCanvas; const Bounds: TRectF; const Row: Integer;
const Value: TValue; const State: TGridDrawStates);
var
R: TRectF;
Layout: TTextLayout;
LocalRow: Integer;
begin
if FDrawable <> nil then
FDrawable.DrawCell(Canvas, Bounds, Row, Value, State)
else
...
...
Layout.Opacity := AbsoluteOpacity;
(*remark this line *****************
Layout.HorizontalAlign := Grid.TextSettingsControl.ResultingTextSettings.HorzAlign;
*)
Layout.HorizontalAlign := HorizontalAlign;//add this line *****
finally you can set the new property in your Project. e.g:
MyColumn.HorizontalAlign:=TTextAlign.taCenter;

Descending columns does not work well with livebindings as the bindmanager creates the columns so you have to mess with descending that. Neither elegant nor practical in my view.
Simply align your cells in the grid OnPainting event.
I := Col;
for J := 0 to Grid1.RowCount - 1 do
begin
T := TTextCell(Grid1.Columns[I].Children[J]);
T.TextAlign := TTextAlign.taTrailing;
end;

If you use livebindings when you have less chance to customize the column class which is being created, but you can create helpers for Column which sets some attributes of individual cell controls. Not too elegant but simple and works:
unit GridColumnHelper;
interface
uses
Fmx.Types, Fmx.Controls, Fmx.Grid, Fmx.Edit;
type
TGridColumnHelper = class helper for TColumn
public
procedure SetEditMaxLength(aValue: Integer);
procedure SetEditTextAlign(aValue: TTextAlign);
end;
implementation
{ TGridColumnHelper }
procedure TGridColumnHelper.SetEditMaxLength(aValue: Integer);
var
lControl: TStyledControl;
begin
for lControl in FCellControls do
begin
if lControl is TEdit then
(lControl as TEdit).MaxLength := aValue;
end;
end;
procedure TGridColumnHelper.SetEditTextAlign(aValue: TTextAlign);
var
lControl: TStyledControl;
begin
for lControl in FCellControls do
begin
if lControl is TEdit then
(lControl as TEdit).TextAlign := aValue;
end;
end;
end.
After the binding has filled the grid, you can call the helpers:
MyGrid.Columns[0].SetEditTextAlign(TTextAlign.taTrailing);
MyGrid.Columns[1].SetEditMaxLength(15);

Solution of "suat dmk" is working fine you have to recompile Fmx.Bind.DBLinks.pas and Fmx.Bind.Editors.pas if you are gonna use DB links.
After that, you simply put in OnPainting event:
SGrid1.ColumnByIndex(1).HorizontalAlign := TTextAlign.Leading;

another solution:
Grid1.ApplyStyleLookup();
MyCol1.DefaultTextSettings.HorzAlign:=TTextAlign.taCenter;

Related

How do I get the MessageDlgPos dimensions?

I want to position a MessageBox in a particular position with respect to the active cell in a string grid and this is no problem using MessageDlgPos() except that I want to prevent the box running off the right or bottom of the screen when the active cell is close to the right or bottom. What I need for this is a way of getting the dimensions of the box but I cannot see a simple way of getting these. Anyone know how without creating my own box?
The MessageDlg...() functions do not support what you are asking for. The dimensions of the dialog are not known until the dialog is being displayed, and you have no way to access the dialog window directly to query/re-position it, except maybe with a WH_CBT hook from SetWindowsHookEx().
That being said...
On Windows Vista+ with Vcl.Dialogs.UseLatestCommonDialogs=true and Visual Styles enabled, the MessageDlg...() functions call the Win32 TaskDialogIndirect() API to display a message box. You have no control over that dialog's dimensions, so you would have to wait for that dialog to issue a TDN_DIALOG_CONSTRUCTED notification to then query its actual dimensions before it is displayed, so you can then adjust its position as needed. However, the MessageDlg...() functions do not provide access to any of TaskDialogIndirect()'s notifications (TCustomTaskDialog, which is used internally, does have an OnDialogConstructed event, amongst other events). So, if you wanted to reposition this dialog, you would have to call TaskDialogIndirect() yourself with a custom callback function (or, use the VCL's TTaskDialog wrapper).
On pre-Vista, or with UseLatestCommonDialogs=false or Visual Styles disabled, the MessageDlg...() functions display a custom VCL TForm via Vcl.Dialogs.CreateMessageDialog() instead, which you can call directly, and then pretty much query, manipulate, and show the returned TForm however you want. Just be sure to Free() it when you are done using it.
You could use an actual TTaskDialog. You can create you own version of it, add a TaskDialogConstructed procedure and get the dimension in the TaskDialogConstructed procedure. Something along the lines of the following.
type
TTaskDialog = class(Vcl.Dialogs.TTaskDialog)
protected
procedure TaskDialogConstructed(Sender: TObject);
end;
procedure TTaskDialog.TaskDialogConstructed(Sender: TObject);
var
TaskDialog: TTaskDialog;
R: TRect;
begin
TaskDialog := Sender as TTaskDialog;
Win32Check(GetWindowRect(TaskDialog.Handle, R));
{... Do whatever with R ...}
end;
function ExecuteTaskDialog(AOwner: TComponent; ATitle, AText: string; ACommonButtons: TTaskDialogCommonButtons = [tcbOK]): integer;
var
TaskDialog: TTaskDialog;
begin
TaskDialog := TTaskDialog.Create(AOwner);
with TaskDialog do
begin
Caption := Application.Title;
Title := ATitle;
Text := AText;
MainIcon := tdiNone;
Flags := Flags + [tfUseHiconMain];
CommonButtons := ACommonButtons;
CustomMainIcon.LoadFromResourceName(HInstance, 'MAINICON');
OnDialogConstructed := TaskDialogConstructed;
Execute;
Result := ModalResult;
Free;
end;
end;
Create the MessageDlg yourself. Add an OnActivate or OnShow event. In this method, ask / change the properties of the dialog.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.StdCtrls;
type
Tfrm = class(TForm)
btn: TButton;
procedure btnClick(Sender: TObject);
private
procedure OnDlgActivate(Sender: TObject);
public
{ Public-Deklarationen }
end;
var
frm: Tfrm;
implementation
uses
Vcl.Dialogs, System.TypInfo;
{$R *.dfm}
procedure Tfrm.btnClick(Sender: TObject);
var
Ldlg : TForm;
LiRet : integer;
begin
Ldlg := CreateMessageDialog('Hallo World!', mtInformation,mbYesNo, mbYes);
try
Ldlg.OnActivate := OnDlgActivate;
LiRet := Ldlg.ShowModal;
finally
Ldlg.free;
end;
end;
procedure Tfrm.OnDlgActivate(Sender: TObject);
var
Lfrm: TForm;
LcTxt: string;
begin
Lfrm := Sender as TForm;
LcTxt := Format('%s %sLeft: %d / Top: %d', [Lfrm.ClassName, sLineBreak, Lfrm.Left, Lfrm.Top]);
ShowMessage(LcTxt);
end;
end.

change the cell color of a StringGrid when entering data in the cell. Delphi

Good evening, I would like to know how to change the color of a cell when writing data in it
I have this...
procedure TFrmReportes.SGDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
begin
if (gdSelected in State) then
begin
SG.Canvas.Brush.Color := rgb(255,119,119);
SG.Canvas.FillRect(SG.CellRect(ACol, ARow));
SG.Canvas.TextOut(Rect.Left+2,Rect.Top+2, SG.Cells[ACol, ARow]);
end;
end;
but when entering data in the cell, it turns white
Thanks Again!!!
TStringGrid displays a TInplaceEdit on top of the cell currently being edited. That TInplaceEdit covers the entire cell. That is why you don't see your custom drawing. You would need to change the TInplaceEdit's Color property instead. You can access the TInplaceEdit via the TStringGrid.InplaceEditor property.
I would suggest deriving a new component from TStringGrid and override its virtual CreateEditor() method. If there is only 1 grid in your Form, a simple interposer would suffice, eg:
type
TStringGrid = class(Vcl.Grids.TStringGrid)
protected
function CreateEditor: TInplaceEdit; override;
end;
TFrmReportes = class(TForm)
SG: TStringGrid;
...
end;
...
type
TInplaceEditAccess = class(TInplaceEdit)
end;
function TStringGrid.CreateEditor: TInplaceEdit;
begin
Result := inherited CreateEditor;
TInplaceEditAccess(Result).Color := RGB(255, 119, 119);
end;
I found the following code that served me thanks to your suggestion in the previous example
with the InplaceEditor property
type
THackGrid = class(TCustomGrid)
public
property InPlaceEditor;
property EditorMode;
end;
TFrmReportes = class(TForm)
SG: TStringGrid;
...
end;
...
procedure TFrmReportes.Button1Click(Sender: TObject);
begin
THackGrid(SG).InPlaceEditor.Brush.Color := RGB(255, 119, 119);
end;
thank you very much

How to avoid duplicate image when rotated in Firemonkey component?

What did I do?
I'm trying to develop a FMX Gauge component. For the time being it has only a needle. I've created a new Package and added the following code:
unit FMX.VDO;
interface
uses
System.SysUtils,
System.Classes,
FMX.Types,
FMX.Controls,
FMX.MultiResBitmap,
FMX.Layouts,
FMX.Objects;
type
TVdoLayout = class(TScaledLayout)
private
FNeedle : TImage;
function GetBitMapNeedle: TFixedMultiResBitmap;
procedure SetBitMapNeedle(const Value: TFixedMultiResBitmap);
function GetValue: Double;
procedure SetValue(const Value: Double);
{ Private declarations }
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
published
{ Published declarations }
property BitMapNeedle : TFixedMultiResBitmap read GetBitMapNeedle write SetBitMapNeedle;
property Value : Double read GetValue write SetValue;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TVdoLayout]);
end;
{ TVdoLayout }
constructor TVdoLayout.Create(AOwner: TComponent);
begin
inherited;
Self.Size.Width := 326;
Self.Size.Height := Self.Size.Width;
FNeedle := TImage.Create(Self);
FNeedle.Parent := Self;
FNeedle.Width := 262;
FNeedle.Height := 21;
FNeedle.Position.X := 40;
FNeedle.Position.Y := 270;
FNeedle.Height := Self.Height * 0.04901;
FNeedle.Width := Self.Width * 0.7485;
FNeedle.RotationCenter.X := 0.935;
FNeedle.RotationCenter.Y := 0.27;
FNeedle.RotationAngle := 45;
end;
function TVdoLayout.GetBitMapNeedle: TFixedMultiResBitmap;
begin
Result := FNeedle.MultiResBitmap;
end;
procedure TVdoLayout.SetBitMapNeedle(const Value: TFixedMultiResBitmap);
begin
FNeedle.MultiResBitmap := Value;
end;
function TVdoLayout.GetValue: Double;
begin
Result := FNeedle.RotationAngle;
end;
procedure TVdoLayout.SetValue(const Value: Double);
begin
FNeedle.RotationAngle := Value;
end;
end.
After this I've build the project and installed my component.
I've created a new FMX project and put my component. I load a picture of a needle in design time. See below:
At design time I can change the property Value. If you see the code above, Value changes RotationAngle of the needle. It works perfectly at design time.
What's the problem?
In run time, when I change the Value property of my component through TEdit to 90 it works, but a snapshot of the initial needle is taken, and it seems duplicate as can be seen below:
Other things that I've tried without success?
I've tried to call resize and repaint functions.
Also added FNeedle.SetSubComponent(True); during Create as #UweRaabe suggested.
If I load the needle image at run time it works. But this is not a desirable solution.
Details
Delphi 10.1 Berlin
FireMonkey (on Windows)
In my searches I found the solution here: Firemonkey: How to define a component that contain another component?
I have just to set the property Stored as False. See below:
FNeedle.Stored := false;

Call Procedure on Separate Unit with Timer

I am trying to write a separate unit for my main form to call, all of my other units are working except for one that uses TTimer.
Basically what the function is supposed to be doing is that the main form uDataReceived calls BlinkRect(Gateway) which is processed in rRectControl unit and the according Rectangle will blink in the main form.
Here are the codes:
unit uRectControl;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Variants, System.IOUtils, FMX.Graphics, FMX.Types, FMX.Objects;
var
Blinks: array [0 .. 2] of record Rectangle: TRectangle;
Timer: TTimer;
end;
type
TMyClass = Class(TObject)
private
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
public
procedure BlinkRect(Gateway: integer);
end;
procedure AssignRectangles;
implementation
uses uDataReceived;
// Error shows "Cannot resolve unit name 'uDataReceived'
{ TMyClass }
procedure AssignRectangles;
var
i: integer;
begin
Blinks[0].Rectangle := TC_Theft_Detection.rect1;
// Error shows Undeclared Identifier TC_Theft_Detection (which is the name of the main form)
Blinks[0].Timer := nil;
Blinks[1].Rectangle := TC_Theft_Detection.rect2;
Blinks[1].Timer := nil;
Blinks[2].Rectangle := TC_Theft_Detection.rect3;
Blinks[2].Timer := nil;
for i := 0 to 2 do
Blinks[i].Rectangle.Fill.Color := TAlphacolors.blue;
end;
procedure TMyClass.BlinkRect(Gateway: integer);
begin
Blinks[Gateway].Rectangle.Fill.Color := TAlphacolors.Red;
Blinks[Gateway].Rectangle.Fill.Kind := TBrushKind.Solid;
Blinks[Gateway].Rectangle.Stroke.Thickness := 0.3;
Blinks[Gateway].Rectangle.Stroke.Color := TAlphacolors.Black;
if Blinks[Gateway].Timer = nil then
begin
Blinks[Gateway].Timer := TTimer.Create(nil);
Blinks[Gateway].Timer.OnTimer := Timer1Timer;
Blinks[Gateway].Timer.Interval := 500;
Blinks[Gateway].Timer.Tag := Gateway;
Blinks[Gateway].Timer.Enabled := True;
end;
end;
procedure TMyClass.Timer1Timer(Sender: TObject);
var
Timer: TTimer;
begin
Timer := TTimer(Sender);
Blinks[Timer.Tag].Rectangle.Visible := not Blinks[Timer.Tag]
.Rectangle.Visible;
end;
end.
I know there must be something wrong with the unit shown above, and my question is:
How to work with TTimer in a separate unit and how to call the procedure BlinkRect(Gateway) on the main form.
Thanks a lot!!
Your code in uRectControl works provided AssignRectangles is called before you attempt to call BlinkRect. However there are a number of issues to be addressed.
1) Cross dependency of units
The form (uDataReceived) apparently uses uRectControl and that is fine. The way uRectControl is written it needs to use (uses uDataReceived in the implementation) the form and this is not good.
This error is simple to correct, because the AssignRectangles procedure is the only place where the form is referred to. AssignRectangles could just as well be in the form, since the Blinks[] array is global (in the interface of uRectControl) and can therefore be accessed by the form.
2) Global variables
Global variables should be avoided as much as possible. You have defined both the Blinks[] array and the Timer to be global, so you might by mistake access and modify them from anywhere in your program just by adding uRectControl to a uses clause. In future development you might add new forms that have indicators you want to blink and add TRectangles to the Blinks[] array possibly overwriting value that are already there and you end up in a mess. I will address this issue in my suggestion below.
3) Hardcoded entities
In Proof Of Concept code it is acceptable (or not) to hardcode constants, sizes of arrays etc. but not in production code. Just think about all changes you need to do just to add one more blinking rectangle to the form. Dynamical arrays or better TList and its derivatives etc. comes to rescue here. You have also limited yourself to only TRectangles. What if you would like to have circular indicators in your form?
4) Unsyncronized blinking
It may look cool (not really) when indicators are blinking all over the place, but actually it is just distracting. I guess you tried to change this with the timer in TMyClass, but you still left the individual timers in the Blinks records. I will address this also in my suggestion below.
Here is a suggestion
unit ShapeBlinker;
interface
uses
System.SysUtils, System.UITypes, System.Classes, System.Generics.Collections,
FMX.Graphics, FMX.Types, FMX.Objects;
type
TBlinkState = (bsOff, bsBlinking, bsSteady);
I have a background in Fire Alarm Systems, and it is common to have three states; off, blinking and steady lit. TBlinkState represents these.
Then comes a class that represent indicators in the UI. An indicator can be any TShape derivative like TRectangle, TCircle, TPath etc. Each state can have its own color.
type
[...]
TBlinkingShape = class
private
FShape: TShape;
FState: TBlinkState;
FOffColor: TAlphaColor;
FBlinkColor: TAlphaColor;
FSteadyColor: TAlphaColor;
public
constructor Create(AShape: TShape);
procedure SetBlinkState(NewState: TBlinkState);
end;
The field FShape holds a reference to a TShape derivative. Through this reference we have access to the actual component on the UI form and can change its color. We will see later how the TShape is passed to the constructor.
Then the second class which manages a collection of TBlinkingShape, timing and actual color changes of the indicators on the form.
type
[...]
TShapeBlinker = class
private
FBlinkingShapes: TObjectList<TBlinkingShape>;
FBlinkPhase: integer;
FTimer: TTimer;
public
constructor Create;
destructor Destroy; override;
procedure RegisterShape(Shape: TShape; OffColor, BlinkColor, SteadyColor: TAlphaColor);
procedure UnRegisterShape(Shape: TShape);
procedure BlinkTimer(Sender: TObject);
procedure SetBlinkState(Shape: TShape; NewState: TBlinkState);
function GetBlinkState(Shape: TShape): TBlinkState;
end;
FBlinkingShapes is the object list that holds instances of TBlinkingShapes.
FBlinkPhase syncronizes blinking of the indicators so that all blinking indicators change to the BlinkColor simultaneously. FTimer is common for all indicators.
Procedure RegisterShape is called by the UI when it wants to add an indicator to the list. UnRegister is called when an indicator is to be removed from the list. SetBlinkState is used to change state and GetBlinkState to retrieve the state of an indicator.
The unit is designed to be usable by any number of forms, synchronizing blinking for all of them. This requires that the TShapeBlinker is a singleton. It is therefore created in the initialization section of the unit, and freed in the finalization.
The instance is held by a var in the implementation, thus inaccessible directly from any other unit. Access is provided by a function declared as the last item in the interface of the unit:
function ShapeBlinker: TShapeBlinker;
This effectively prevents a mistake to accidentally call ShapeBlinker.Create.
Instead of commenting on each method I just copy the implementation here:
implementation
var
SShapeBlinker: TShapeBlinker;
function ShapeBlinker: TShapeBlinker;
begin
result := SShapeBlinker;
end;
{ TBlinkingShape }
constructor TBlinkingShape.Create(AShape: TShape);
begin
FShape := AShape;
FState := bsOff;
end;
procedure TBlinkingShape.SetBlinkState(NewState: TBlinkState);
begin
FState := NewState;
case NewState of
bsOff: begin
FShape.Fill.Color := FOffColor;
end;
bsBlinking: begin
FShape.Fill.Color := FBlinkColor;
end;
bsSteady: begin
FShape.Fill.Color := FSteadyColor;
end;
end;
end;
{ TShapeBlinker }
constructor TShapeBlinker.Create;
begin
FBlinkingShapes := TObjectList<TBlinkingShape>.Create;
FTimer := TTimer.Create(nil);
FTimer.OnTimer := BlinkTimer;
FTimer.Interval := 500;
FTimer.Enabled := False;
end;
destructor TShapeBlinker.Destroy;
begin
FTimer.Enabled := False;
FTimer.Free;
FBlinkingShapes.Free;
inherited;
end;
function TShapeBlinker.GetBlinkState(Shape: TShape): TBlinkState;
var
RegShape: TBlinkingShape;
begin
result := bsOff;
for RegShape in FBlinkingShapes do
if Shape = RegShape.FShape then result := RegShape.FState;
end;
procedure TShapeBlinker.SetBlinkState(Shape: TShape; NewState: TBlinkState);
var
RegShape: TBlinkingShape;
begin
for RegShape in FBlinkingShapes do
if Shape = RegShape.FShape then RegShape.SetBlinkState(NewState);
self.FTimer.Enabled := True;
end;
procedure TShapeBlinker.BlinkTimer(Sender: TObject);
var
i: integer;
begin
FTimer.Enabled := False;
FBlinkPhase := (FBlinkPhase + 1) mod 2;
for i := 0 to FBlinkingShapes.Count-1 do
with FBlinkingShapes[i] do
begin
case FState of
bsOff: begin
FShape.Fill.Color := FOffColor;
end;
bsBlinking: begin
if FBlinkPhase = 1 then
FShape.Fill.Color := FOffColor // alt. FSteadyColor
else
FShape.Fill.Color := FBlinkColor;
FTimer.Enabled := True;
end;
bsSteady: begin
FShape.Fill.Color := FSteadyColor;
end;
end;
end;
end;
procedure TShapeBlinker.RegisterShape(Shape: TShape; OffColor, BlinkColor, SteadyColor: TAlphaColor);
begin
with FBlinkingShapes[FBlinkingShapes.Add(TBlinkingShape.Create(Shape))] do
begin
FOffColor := OffColor; //TAlphaColors.Silver;
FBlinkColor := BlinkColor; //TAlphaColors.Red;
FSteadyColor := SteadyColor; //TAlphaColors.Yellow;
end;
end;
procedure TShapeBlinker.UnRegisterShape(Shape: TShape);
var
i: integer;
begin
for i := FBlinkingShapes.Count-1 downto 0 do
if FBlinkingShapes[i].FShape = Shape then
FBlinkingShapes.Delete(i);
end;
initialization
SShapeBlinker := TShapeBlinker.Create;
finalization
SShapeBlinker.Free;
end.
Finally a few words about usage. Consider a form, say TAlarmView, with 2 TRectangle and 1 TCircle.
In FormCreate you might register these for blinking as follows
procedure TAlarmView.FormCreate(Sender: TObject);
begin
ShapeBlinker.RegisterShape(Rect1, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
ShapeBlinker.RegisterShape(Circle1, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
ShapeBlinker.RegisterShape(Rect3, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
end;
and then test them with button clicks like
procedure TAlarmView.Button1Click(Sender: TObject);
begin
case ShapeBlinker.GetBlinkState(Rect1) of
bsOff: ShapeBlinker.SetBlinkState(Rect1, bsBlinking);
bsBlinking: ShapeBlinker.SetBlinkState(Rect1, bsSteady);
else ShapeBlinker.SetBlinkState(Rect1, bsOff);
end;
end;
As you see I just go through the different states for each click.

How to prevent editing unempty cells in tstringgrid in delphi 7?

I have a problem and need your help
I am going to work on sudoku game. In my Stringgrid I've filled some cells with digits before [grid1.cells[8,8]:=inttostr(2); grid1.cells[2,5]:=inttostr(9); etc] and digits' text font color are black. Now I want player cannot change(edit) previous values and only able to add to empty cells(can change only its own values).
And values inserted into cells have to be diffent text font color(exp: clRed)
I need help in this two cases.
Thanks in advance .
There is no public way to interrupt process of cell editing, but you can make a TStringGrid subclass and override its CanEditShow protected method. In this control subclass, you can e.g. make an event to control whether the inplace editor will be created or not.
The following interposer class introduces the OnCanEdit event which will fire before the inplace editor is created and allows to you decide whether you want to create it or not by its CanEdit parameter:
type
TCanEditEvent = procedure(Sender: TObject; Col, Row: Longint;
var CanEdit: Boolean) of object;
TStringGrid = class(Grids.TStringGrid)
private
FOnCanEdit: TCanEditEvent;
protected
function CanEditShow: Boolean; override;
public
property OnCanEdit: TCanEditEvent read FOnCanEdit write FOnCanEdit;
end;
implementation
{ TStringGrid }
function TStringGrid.CanEditShow: Boolean;
begin
Result := inherited CanEditShow;
if Result and Assigned(FOnCanEdit) then
FOnCanEdit(Self, Col, Row, Result);
end;
This example shows how to allow editing only for cells with row and column index greater than 2, which is not your case, but I'm sure you understand what to do:
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure FormCreate(Sender: TObject);
private
procedure StringGridCanEdit(Sender: TObject; Col, Row: Longint;
var CanEdit: Boolean);
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.OnCanEdit := StringGridCanEdit;
end;
procedure TForm1.StringGridCanEdit(Sender: TObject; Col, Row: Integer;
var CanEdit: Boolean);
begin
// to the CanEdit parameter assign True if you want to allow the cell
// to be edited, False if you don't
CanEdit := (Col > 2) and (Row > 2);
end;
Although the question is over 4 years old I am answering because the initial Answer is not absolutely correct. In fact there is a way to prevent editing specific cells:
You can set the CanSelect parameter of the TStringGrid OnSelectCell:
procedure TForm1.FormCreate(Sender: TObject);
begin
StringGrid1.Options := StringGrid1.Options+[goEditing];
StringGrid1.Cells[2,3] := '3';
StringGrid1.Objects[2,3] := Pointer(1);
end;
procedure TForm1.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
begin
if StringGrid1.Objects[ACol,ARow]<>nil then
CanSelect := false;
end;
The decision to block a cell can be done by setting a blocking value to the corresponding Objects

Resources