FireMonkey2: Why the primitive component do not respond to the Fill Property - delphi-xe2
I've created a new component named : TRegularPolygon from the exemple on the Embarcadero web site. This component work well on FM1 (XE2) but on XE3 and above, the Fill.Color property do not respond.
At design-time in XE4 and XE5 the component is filled black and in run-time the component is filled in white. If we change the fill.color property programatically on the running program, the fill.color property work. This component is derivated from TShape. I've tried to compare with other Tshape components like TRectangular and TCircle and those components work well in all XEx version.
Here is the code of the component (for XE5) -->
unit RegularPolygon;
interface
uses
System.SysUtils, System.Classes, System.Types, System.Math, System.UITypes, FMX.Types, FMX.Controls, FMX.Objects, FMX.Graphics;
type
TRegularPolygon = class(TShape)
private
{ Private declarations }
FNumberOfSides: Integer;
FPath: TPathData;
procedure SetNumberOfSides(const Value: Integer);
protected
{ Protected declarations }
procedure CreatePath;
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function PointInObject(X, Y: Single): Boolean; override;
published
{ Published declarations }
property NumberOfSides: Integer read FNumberOfSides write SetNumberOfSides;
property Align;
property Anchors;
property ClipChildren default False;
property ClipParent default False;
property Cursor default crDefault;
property DesignVisible default True;
property DragMode default TDragMode.dmManual;
property EnableDragHighlight default True;
property Enabled default True;
property Fill;
property Locked default False;
property Height;
property HitTest default True;
property Padding;
property Opacity;
property Margins;
property PopupMenu;
property Position;
property RotationAngle;
property RotationCenter;
property Scale;
property StrokeThickness stored false;
property StrokeCap stored false;
property StrokeDash stored false;
property StrokeJoin stored false;
property Stroke;
property Visible default True;
property Width;
end;
procedure Register;
////////////////////////////////////////////////////////////////////////////////
implementation
procedure Register;
begin
RegisterComponents('Shape2', [TRegularPolygon]);
end;
{ TRegularPolygon }
constructor TRegularPolygon.Create(AOwner: TComponent);
begin
inherited;
FNumberOfSides := 3;
FPath := TPathData.Create;
end;
destructor TRegularPolygon.Destroy;
begin
FreeAndNil(FPath);
inherited;
end;
procedure TRegularPolygon.SetNumberOfSides(const Value: Integer);
begin
if (FNumberOfSides <> Value) and (Value >= 3) then
begin
FNumberOfSides := Value;
Repaint;
end;
end;
procedure TRegularPolygon.CreatePath;
procedure GoToAVertex(n: Integer; Angle, CircumRadius: Double;
IsLineTo: Boolean = True);
var
NewLocation: TPointF;
begin
NewLocation.X := Width / 2 + Cos(n * Angle) * CircumRadius;
NewLocation.Y := Height / 2 - Sin(n * Angle) * CircumRadius;
if IsLineTo then
FPath.LineTo(NewLocation)
else
FPath.MoveTo(NewLocation);
end;
var
i: Integer;
Angle, CircumRadius: Double;
begin
Angle := 2 * PI / FNumberOfSides;
CircumRadius := Min(ShapeRect.Width / 2, ShapeRect.Height / 2);
// Create a new Path
FPath.Clear;
// MoveTo the first point
GoToAVertex(0, Angle, CircumRadius, False);
// LineTo each Vertex
for i := 1 to FNumberOfSides do
GoToAVertex(i, Angle, CircumRadius);
FPath.ClosePath;
end;
procedure TRegularPolygon.Paint;
begin
CreatePath;
Canvas.FillPath(FPath, AbsoluteOpacity);
Canvas.DrawPath(FPath, AbsoluteOpacity);
//Canvas.FillRect(R, XRadius, YRadius, FCorners, AbsoluteOpacity, FFill, CornerType);
//Canvas.DrawRect(R, XRadius, YRadius, FCorners, AbsoluteOpacity, FStroke, CornerType);
end;
function TRegularPolygon.PointInObject(X, Y: Single): Boolean;
begin
CreatePath;
Result := Canvas.PtInPath(AbsoluteToLocal(PointF(X, Y)), FPath);
end;
end.
I.ve found a way to have the Fill.color property working, I've reimplemented the TBrush (FFill) normally provided by TShape and change the implementation of the Paint procedure
from
Canvas.FillPath(FPath, AbsoluteOpacity);
to
Canvas.FillPath(FPath, AbsoluteOpacity, FFill);
here is the new code:
unit RegularPolygon;
interface
uses
System.SysUtils, System.Classes, System.Types, System.Math, System.UITypes, FMX.Types, FMX.Controls, FMX.Objects, FMX.Graphics;
type
TRegularPolygon = class(TShape)
private
{ Private declarations }
FNumberOfSides: Integer;
FPath: TPathData;
FFill: TBrush;
procedure SetFill(const Value: TBrush);
procedure SetNumberOfSides(const Value: Integer);
protected
{ Protected declarations }
procedure FillChangedNT(Sender: TObject); virtual;
procedure CreatePath;
procedure Paint; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function PointInObject(X, Y: Single): Boolean; override;
published
{ Published declarations }
property NumberOfSides: Integer read FNumberOfSides write SetNumberOfSides;
property Align;
property Anchors;
property ClipChildren default False;
property ClipParent default False;
property Cursor default crDefault;
property DesignVisible default True;
property DragMode default TDragMode.dmManual;
property EnableDragHighlight default True;
property Enabled default True;
//property Fill;
property Fill: TBrush read FFill write SetFill;
property Locked default False;
property Height;
property HitTest default True;
property Padding;
property Opacity;
property Margins;
property PopupMenu;
property Position;
property RotationAngle;
property RotationCenter;
property Scale;
property StrokeThickness stored false;
property StrokeCap stored false;
property StrokeDash stored false;
property StrokeJoin stored false;
property Stroke;
property Visible default True;
property Width;
end;
procedure Register;
////////////////////////////////////////////////////////////////////////////////
implementation
procedure Register;
begin
RegisterComponents('Shape2', [TRegularPolygon]);
end;
{ TRegularPolygon }
constructor TRegularPolygon.Create(AOwner: TComponent);
begin
inherited;
FFill := TBrush.Create(TBrushKind.bkSolid, $FFE0E0E0);
FFill.OnChanged := FillChanged;
//FStroke := TStrokeBrush.Create(TBrushKind.bkSolid, $FF000000);
//FStroke.OnChanged := StrokeChanged;
FNumberOfSides := 3;
FPath := TPathData.Create;
end;
destructor TRegularPolygon.Destroy;
begin
//FStroke.Free;
FFill.Free;
FreeAndNil(FPath);
inherited;
end;
procedure TRegularPolygon.FillChangedNT(Sender: TObject);
begin
if FUpdating = 0 then
Repaint;
end;
procedure TRegularPolygon.SetFill(const Value: TBrush);
begin
FFill.Assign(Value);
end;
procedure TRegularPolygon.SetNumberOfSides(const Value: Integer);
begin
if (FNumberOfSides <> Value) and (Value >= 3) then
begin
FNumberOfSides := Value;
Repaint;
end;
end;
procedure TRegularPolygon.CreatePath;
procedure GoToAVertex(n: Integer; Angle, CircumRadius: Double;
IsLineTo: Boolean = True);
var
NewLocation: TPointF;
begin
NewLocation.X := Width / 2 + Cos(n * Angle) * CircumRadius;
NewLocation.Y := Height / 2 - Sin(n * Angle) * CircumRadius;
if IsLineTo then
FPath.LineTo(NewLocation)
else
FPath.MoveTo(NewLocation);
end;
var
i: Integer;
Angle, CircumRadius: Double;
begin
Angle := 2 * PI / FNumberOfSides;
CircumRadius := Min(ShapeRect.Width / 2, ShapeRect.Height / 2);
// Create a new Path
FPath.Clear;
// MoveTo the first point
GoToAVertex(0, Angle, CircumRadius, False);
// LineTo each Vertex
for i := 1 to FNumberOfSides do
GoToAVertex(i, Angle, CircumRadius);
FPath.ClosePath;
end;
procedure TRegularPolygon.Paint;
begin
CreatePath;
Canvas.FillPath(FPath, AbsoluteOpacity, FFill);
Canvas.DrawPath(FPath, AbsoluteOpacity);
//Canvas.DrawPath(FPath, AbsoluteOpacity, FStroke);
end;
function TRegularPolygon.PointInObject(X, Y: Single): Boolean;
begin
CreatePath;
Result := Canvas.PtInPath(AbsoluteToLocal(PointF(X, Y)), FPath);
end;
end.
Related
TIDTCPClient EAccessViolation
I have a RFID reader that comes with a RFTT service. I start the service and try to access it with TidTCPClient, but I get an access violation as soon I try to connect. Read of Address 00000000
As soon it click connect I get the message.
unit UClient;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, IdBaseComponent,
IdComponent, IdTCPConnection, IdTCPClient, IdThreadComponent;
type
TFClient = class(TForm)
Label1 : TLabel;
Label2 : TLabel;
messageToSend : TMemo;
messagesLog : TMemo;
btn_connect : TButton;
btn_disconnect: TButton;
btn_send : TButton;
procedure FormShow(Sender: TObject);
procedure btn_connectClick(Sender: TObject);
procedure btn_disconnectClick(Sender: TObject);
procedure btn_sendClick(Sender: TObject);
procedure IdTCPClientConnected(Sender: TObject);
procedure IdTCPClientDisconnected(Sender: TObject);
procedure IdThreadComponentRun(Sender: TIdThreadComponent);
procedure Display(p_sender: String; p_message: string);
function GetNow():String;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
// ... listening port : GUEST CLIENT
const GUEST_PORT = 5733;
var
FClient : TFClient;
// ... TIdTCPClient
idTCPClient : TIdTCPClient;
// ... TIdThreadComponent
idThreadComponent : TIdThreadComponent;
implementation
{$R *.dfm}
procedure TFClient.FormCreate(Sender: TObject);
begin
// ... create TIdTCPClient
idTCPClient := TIdTCPClient.Create();
// ... set properties
idTCPClient.Host := 'localhost';
idTCPClient.Port := GUEST_PORT;
idTCPClient.ConnectTimeout := 5000;
// ... etc..
// ... callback functions
idTCPClient.OnConnected := IdTCPClientConnected;
idTCPClient.OnDisconnected := IdTCPClientDisconnected;
// ... etc..
// ... create TIdThreadComponent
idThreadComponent := TIdThreadComponent.Create();
// ... callback functions
idThreadComponent.OnRun := IdThreadComponentRun;
// ... etc..
end;
procedure TFClient.FormShow(Sender: TObject);
begin
// ... INITAILIZE
// ... message to send
messageToSend.Clear;
messageToSend.Enabled := False;
// ... clear log
messagesLog.Clear;
// ... buttons
btn_connect.Enabled := True;
btn_disconnect.Enabled := False;
btn_send.Enabled := False;
end;
procedure TFClient.btn_connectClick(Sender: TObject);
begin
// ... disable connect button
btn_connect.Enabled := False;
// ... try to connect to Server
try
IdTCPClient.Connect;
except
on E: Exception do begin
Display('CLIENT', 'CONNECTION ERROR! ' + E.Message);
btn_connect.Enabled := True;
end;
end;
end;
procedure TFClient.btn_disconnectClick(Sender: TObject);
begin
// ... is connected?
if IdTCPClient.Connected then begin
// ... disconnect from Server
IdTCPClient.Disconnect;
// ... set buttons
btn_connect.Enabled := True;
btn_disconnect.Enabled := False;
btn_send.Enabled := False;
messageToSend.Enabled := False;
end;
end;
procedure TFClient.IdTCPClientConnected(Sender: TObject);
begin
// ... messages log
Display('CLIENT', 'CONNECTED!');
// ... after connection is ok, run the Thread ... waiting messages from server
IdThreadComponent.Active := True;
// ... set buttons
btn_connect.Enabled := False;
btn_disconnect.Enabled := True;
btn_send.Enabled := True;
// ... enable message to send
messageToSend.Enabled := True;
end;
procedure TFClient.IdTCPClientDisconnected(Sender: TObject);
begin
// ... message log
Display('CLIENT', 'DISCONNECTED!');
end;
procedure TFClient.IdThreadComponentRun(Sender: TIdThreadComponent);
var
msgFromServer : string;
begin
// ... read message from server
msgFromServer := IdTCPClient.IOHandler.ReadLn();
// ... messages log
Display('SERVER', msgFromServer);
end;
procedure TFClient.Display(p_sender : String; p_message : string);
begin
TThread.Queue(nil, procedure
begin
MessagesLog.Lines.Add('[' + p_sender + '] - '
+ GetNow() + ': ' + p_message);
end
);
end;
function TFClient.getNow() : String;
begin
Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ';
end;
end.
This is the whole program unfortunately I have to put all this text because it will not let me post with out more detailed text.
Thanks for any help,
KimHJ
As Remy suggested after dropping the component on the form and us those instead, everything worked fine.
Delphi flow with indy
The program freezes as usual. how to do in the flow ?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCookieManager, IdIOHandler, IdIOHandlerSocket,
IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, ExtCtrls, Unit2;
type
TForm1 = class(TForm)
IdHTTP1: TIdHTTP;
IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
IdCookieManager1: TIdCookieManager;
Button1: TButton;
Memo1: TMemo;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
private
my:myth;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
my:=myth.Create(true);
my.Priority:=tpNormal;
my.FreeOnTerminate:=True;
my.Resume;
end;
end.
FLOW
unit Unit2;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdCookieManager, IdIOHandler, IdIOHandlerSocket,
IdIOHandlerStack, IdSSL, IdSSLOpenSSL, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, ExtCtrls;
type
myth = class(TThread)
IdHTTP1: TIdHTTP;
IdSSLIOHandlerSocketOpenSSL1: TIdSSLIOHandlerSocketOpenSSL;
IdCookieManager1: TIdCookieManager;
Button1: TButton;
Memo1: TMemo;
Timer1: TTimer;
private
{ Private declarations }
protected
procedure Execute; override;
procedure meme;
public
end;
implementation
uses Unit1;
procedure myth.Execute;
begin
Synchronize(meme);
end;
procedure myth.meme;
var
s: string;
list, lista: TStringList;
resul: string;
begin
list := TStringList.Create;
Form1.Memo1.Clear;
list.Add('...');
list.Add('...');
list.Add('...');
list.Add('...');
s := IdHTTP1.Post('https://,list);
list.Free;
(LOGIN)
resul := idHTTP1.Get('...');
while Pos('tdn',resul) > 0 do begin //PRESS ON BUTTON
lista := TStringList.Create;
lista.Add('...');
IdHTTP1.Post('https:...,lista);
lista.Free;
end;
end;
end.
You are creating a worker thread just to Synchronize() all of its work back to the main UI thread. Don't do that! Only synchronize the pieces that actually need it. Have the thread call meme() directly without Synchronize(), and then have meme() use Synchronize() to access Form1.Memo1 and anything else that touches the UI. Your TStringList and TIdHTTP operations themselves don't need to be synchronized since they are local to meme() (if you create your IdHTTP1, IdSSLIOHandlerSocketOpenSSL1, and IdCookieManager1 objects dynamically in the thread, instead of on the Form at design-time).
Try something more like this instead:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, Unit2;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
private
my: myth;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
my := myth.Create;
end;
end.
FLOW
unit Unit2;
interface
uses
Classes, IdCookieManager, IdSSLOpenSSL, IdHTTP;
type
myth = class(TThread)
IdHTTP: TIdHTTP;
IdSSLIOHandlerSocketOpenSSL: TIdSSLIOHandlerSocketOpenSSL;
IdCookieManager: TIdCookieManager;
private
{ Private declarations }
procedure meme;
protected
procedure Execute; override;
public
constructor Create; reintroduce;
destructor Destroy; override;
end;
implementation
uses Unit1;
constructor myth.Create;
begin
inherited Create(False);
Priority := tpNormal;
FreeOnTerminate := True;
IdHTTP := TIdHTTP.Create(nil);
IdSSLIOHandlerSocketOpenSSL := TIdSSLIOHandlerSocketOpenSSL.Create(IdHTTP);
// configure as needed...
IdHTTP.IOHandler := IdSSLIOHandlerSocketOpenSSL;
IdCookieManager := TIdCookieManager.Create(IdHTTP);
// configure as needed...
IdHTTP.CookieManager := IdCookieManager;
end;
destructor myth.Destroy;
begin
IdHTTP.Free;
inherited;
end;
procedure myth.Execute;
begin
meme;
end;
procedure myth.meme;
var
list: TStringList;
resul: string;
begin
list := TStringList.Create;
try
Synchronize(ClearMemo);
list.Add('...');
list.Add('...');
list.Add('...');
list.Add('...');
s := IdHTTP1.Post('https://...', list);
list.Clear;
...
resul := IdHTTP1.Get('...');
while Pos('tdn', resul) > 0 do begin
list.Clear;
list.Add('...');
IdHTTP1.Post('https://...', list);
list.Clear;
end;
finally
list.Free;
end;
end;
procedure myth.ClearMemo;
begin
Form1.Memo1.Clear;
end;
end.
Interfaces, properties and procedure of object FPC
While implementing my own observer framework I got a problem: I can't execute procedures of object when they are returned in getter. I have here an example program for Lazarus. What should I do to see "TRUE" in console? (Now program returns false). It's a complete program, you can just copy-paste it.
program project1;
{$mode objfpc}
uses
SysUtils,
Classes;
type
TEvent = procedure of object;
{ IInterface }
IInterface = interface
function GetEvent: TEvent;
procedure SetEvent(AValue: TEvent);
property Event: TEvent read GetEvent write SetEvent;
end;
{ TMYClass }
TMYClass = class(TInterfacedObject, IInterface)
private
FEvent: TEvent;
public
function GetEvent: TEvent;
procedure SetEvent(AValue: TEvent);
property Event: TEvent read GetEvent write SetEvent;
end;
{ TAnotherClass }
TAnotherClass = class
FVariable: boolean;
constructor Create;
procedure Handler;
end;
{ TAnotherClass }
constructor TAnotherClass.Create;
begin
FVariable := False;
end;
procedure TAnotherClass.Handler;
begin
FVariable := True;
end;
function TMYClass.GetEvent: TEvent;
begin
Result := FEvent;
end;
procedure TMYClass.SetEvent(AValue: TEvent);
begin
FEvent := AValue;
end;
var
LInterface: IInterface;
LAnother: TAnotherClass;
begin
LInterface := TMYClass.Create;
LAnother := TAnotherClass.Create;
LInterface.Event:=#LAnother.Handler;
LInterface.Event;
WriteLn(LAnother.FVariable);
ReadLn();
end.
When I debug this, it looks as if Result isn't assigned in TMYClass.GetEvent. Do you know, what is my problem?
TCustomControl does not trigger the Paint method
I have the following code:
tExCustomControl = class (tCustomControl)
private
procedure Paint; override;
end;
tMyControl : class (tExCustomControl)
private
procedure Paint; override;
public
constructor Create (AOwner: TComponent);
...
end;
...
implementation
{ tExCustomControl }
procedure tExCustomControl.Paint;
begin
inherited;
...
end;
{ tMyControl }
procedure tMyControl.Paint (Sender: TObject);
begin
inherited;
...
end;
It was working fine, but for some reason, now is not triggering no one of the Paint methods. Can anyone tell me what's wrong? Thanks.
Delphi: how to make procedure on click on button array?
I have to make project in Delphi. I made an array of buttons and an array of images. I want to show Image[i] when I click button[i]. Can somebody help please?
How about using the button's tag property to store a pointer to the correlating image. I'm unsure of your Array structure but here's a code snippet to demonstrate.
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Button2: TButton;
Image2: TImage;
procedure FormCreate(Sender: TObject);
private
FMyCurrentImage : TImage; //Keeps track of the current image
procedure MyButtonClick(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FMyCurrentImage := nil;
Button1.Tag := Integer(Image1);
Button1.OnClick := MyButtonClick;
Image1.Hide;
Button2.Tag := Integer(Image2);
Button2.OnClick := MyButtonClick;
Image2.Hide;
end;
procedure TForm1.MyButtonClick(Sender: TObject);
begin
if Sender is TButton then
with Sender as TButton do
if Assigned(TImage(Tag)) then
begin
//Hide the previously selected image
if Assigned(FMyCurrentImage) then
FMyCurrentImage.Hide;
//Assign and show the clicked button's image
FMyCurrentImage := TImage(Tag);
FMyCurrentImage.Show;
end;
end;
What kind of component are you using in your form to show the image?
I don't know what you really need, but here's something I guess you'd want:
I have created three components in the form to test it: two TButton's and one of TImage type.
TfrmTest = class(TForm)
btn1: TButton;
btn2: TButton;
img: TImage;
procedure showImage(sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
In the var section:
var
frmTest: TfrmTest;
imagesArray: array[1..2] of String = ('blue.jpg', 'red.jpg');
buttonsArray: array[1..2] of String = ('btn1', 'btn2');
The implementation of your event:
procedure TfrmTest.showImage(sender: TObject);
var
i: integer;
begin
for i := low(buttonsArray) to high(buttonsArray) do
begin
if (buttonsArray[i] = TButton(sender).name) then
begin
img.picture.loadFromFile('your images directory path here' + imagesArray[i]);
break;
end;
end;
end;
In the Object Inspector, you need to set the OnClick event of your buttons with the showImage procedure.