I have a code here:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
IInnerTest = interface (IInterface)
procedure DoSth;
end;
TRekScannerData = record
Source: Integer;
Device: IInnerTest;
end;
ITest = interface (IInterface)
procedure DoSth;
end;
ATest = class(TInterfacedObject, ITest)
private
FInner: Array of TRekScannerData;
public
procedure DoSth;
constructor Create();
Destructor Destroy();override;
end;
AInnerTest = class (TInterfacedObject, IInnerTest)
private
FMainInt: ITest;
public
constructor Create(MainInt: ITest);
procedure DoSth;
Destructor Destroy();override;
end;
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
test: ITest;
implementation
{$R *.dfm}
{ ATest }
constructor ATest.Create;
begin
SetLength(FInner, 1);
FInner[0].Device := AInnerTest.Create(self);
//<----- Here is the reason. Passing main interface to the inner interface.
end;
destructor ATest.Destroy;
begin
beep;
inherited;
end;
procedure ATest.DoSth;
begin
//
end;
{ AInnerTest }
constructor AInnerTest.Create(MainInt: ITest);
begin
FMainInt := MainInt;
end;
destructor AInnerTest.Destroy;
begin
beep;
inherited;
end;
procedure AInnerTest.DoSth;
begin
//
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
test := ATest.Create;
test.DoSth;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
test := nil;
end;
end.
The problem is that Destroy is not called when test is assigned to nil;
I would like to release all the inner interfaces by one statement ...
Is it possible? or do I need to prior to nil destroy all inner structures by using another method?
EDIT
The class structure is as follows:
Var x = ITest(ATest class) has ->
Inner Interface: IInnerTest(AInnerTest class) which has reference to:
ITest(ATest class)
Nil'ing x doesn't release all structure ...
You have a circular reference. Your implementation of IInnerTest holds a reference to ITest. And your implementation of ITest holds a reference to IInnerTest. And this circular reference means that the interface reference count can never go to zero.
The normal solution to this issue to to use a weak reference. Some useful links:
"Weak reference": down to earth explanation needed
http://www.finalbuilder.com/Resources/Blogs/PostId/410/WeakRefence-in-Delphi-solving-circular-interfac.aspx
http://delphisorcery.blogspot.co.uk/2012/06/weak-interface-references.html
Related
I have this code with which I can set the font size of the control hint, but I want to be able somehow to adjust it later at runtime. How can I do that ?
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TMyHintWindow = class(THintWindow)
constructor Create(AOwner: TComponent); override;
end;
TMyButton = class(TButton)
protected
procedure CMHintShow(var Message: TCMHintShow); message CM_HINTSHOW;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
MyButton: TMyButton;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
MyButton:=TMyButton.Create(Form1);
MyButton.Parent:=Form1;
MyButton.Caption:='Test';
MyButton.Left:=100;
MyButton.Top:=100;
MyButton.ShowHint:=true;
end;
procedure TMyButton.CMHintShow(var Message: TCMHintShow);
begin
inherited;
Message.HintInfo.HintWindowClass:=TMyHintWindow;
Message.HintInfo.HintStr:='My custom hint';
end;
constructor TMyHintWindow.Create(AOwner: TComponent);
begin
inherited;
Canvas.Font.Size:=25;
end;
end.
Since there is only one hint window instance at the time, and that instance will be created after call to CMHintShow, you can use class variables to do additional hint customization. Class variable is class member that is shared among all instances of the class and can be accessed directly through class type or class instance.
type
TMyHintWindow = class(THintWindow)
protected
class constructor ClassCreate;
public
class var FontSize: integer;
constructor Create(AOwner: TComponent); override;
end;
class constructor TMyHintWindow.ClassCreate;
begin
FontSize := 25;
end;
constructor TMyHintWindow.Create(AOwner: TComponent);
begin
inherited;
Canvas.Font.Size := FontSize;
end;
and then you can change FontSize in CMHintShow method
procedure TMyButton.CMHintShow(var Message: TCMHintShow);
begin
inherited;
TMyHintWindow.FontSize := 12;
Message.HintInfo.HintWindowClass := TMyHintWindow;
Message.HintInfo.HintStr := 'My custom hint';
end;
Starting from indications given by TLama I finally solved this problem. The key was to set Canvas.Font.Size in TMyHintWindow.CalcHintRect.
Here is the code:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TMyHintData = record
FontSize: Integer;
end;
TMyHintWindow = class(THintWindow)
public
function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect; override;
end;
TMyButton = class(TButton)
private
procedure CMHintShow(var AMessage: TCMHintShow); message CM_HINTSHOW;
public
FMyHintData: TMyHintData;
constructor Create(AOwner: TComponent); override;
end;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
MyButton: TMyButton;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
TMyButton(Sender).FMyHintData.FontSize:=44;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MyButton:=TMyButton.Create(Form1);
MyButton.Parent:=Form1;
MyButton.Caption:='Test';
MyButton.Left:=100;
MyButton.Top:=100;
MyButton.ShowHint:=true;
MyButton.OnClick:=Button1Click;
end;
function TMyHintWindow.CalcHintRect(MaxWidth: Integer; const AHint: string; AData: TCustomData): TRect;
begin
Canvas.Font.Size:=TMyHintData(AData^).FontSize;
Result:=inherited;
end;
constructor TMyButton.Create(AOwner: TComponent);
begin
inherited;
FMyHintData.FontSize:=25;
end;
procedure TMyButton.CMHintShow(var AMessage: TCMHintShow);
begin
inherited;
AMessage.HintInfo.HintData:=#FMyHintData;
AMessage.HintInfo.HintWindowClass:=TMyHintWindow;
AMessage.HintInfo.HintStr:='My custom hint';
end;
end.
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.OnShowHint:=AppOnShowHint;
end;
procedure TForm1.AppOnShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);
begin
{Use HintInfo (type:THintInfo) to specify some property of hint-window}
{For example: set hint-window width to the width of longest word in the hint-text}
HintInfo.HintMaxWidth:=1;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
{Set HintFont at runtime}
Screen.HintFont.Size:=strtoint(Edit1.Text);
{It's necessary to recreate the Application.FHintWindow private variable, so:}
Application.ShowHint:=False;
Application.ShowHint:=True;
end;
I have the following class hierarchy
I would like to be able to dynamically assign anonymous methods which operate on objects of both types TB and TC.
So here is a simple contrived example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TNotifyEventWrapper = class
private
FProc: TProc<TObject>;
public
constructor Create(Proc: TProc<TObject>);
published
procedure Event(Sender: TObject);
end;
IA = interface
procedure Foo;
end;
TA = class(TInterfacedObject)
procedure Foo;
end;
TB = class(TA, IA)
procedure Foo;
end;
TC = class(TA, IA)
procedure Foo;
end;
TControl = class
strict private
public
class var NEW : TNotifyEventWrapper;
class var Foo : TNotifyEvent;
class function GetWrapper<T:TA, IA, constructor>(D: T): TNotifyEventWrapper;
class procedure AssignFooHandler<T:TA, IA, constructor>;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TC.Foo;
begin
ShowMessage('TC.Foo');
end;
class function TControl.GetWrapper<T>(D: T): TNotifyEventWrapper;
begin
Result :=
TNotifyEventWrapper.Create
(
procedure (S : TObject)
begin
T(D).Foo;
end
);
end;
class procedure TControl.AssignFooHandler<T>;
var
X : T;
begin
X := T.Create;
try
TControl.NEW := TControl.GetWrapper<T>(X);
TControl.Foo := TControl.NEW.Event;
finally
FreeAndNil(X);
end;
end;
procedure TA.Foo;
begin
ShowMessage('TA.Foo');
end;
procedure TB.Foo;
begin
ShowMessage('TB.Foo');
end;
constructor TNotifyEventWrapper.Create(Proc: TProc<TObject>);
begin
inherited Create;
FProc := Proc;
end;
procedure TNotifyEventWrapper.Event(Sender: TObject);
begin
FProc(Sender);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
TControl.Foo(Sender);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
TControl.AssignFooHandler<TC>; //TB
end;
end.
I would like to be able to call
TControl.AssignFooHandler<TC>;
And have the TControl.Foo(Sender); method invoke TC.Foo
Also I want TControl.AssignFooHandler<TB>; to result in TControl.Foo(Sender); invoking TB.Foo
Unfortunately, when I run this, it always invokes the base class method TA.Foo.
I'm not sure how to get around this.
Your Generic is constrained to descendants of TA and IA. TA.Foo is not declared as virtual, and T(B|C).Foo() are not declared to override it. That is why TA.Foo() is being called every time. You need to make TA.Foo() virtual and T(B|C).Foo override it, then T(B/C).Foo will get called as expected.
Also, you are freeing the T(A/B/C) object that you are passing to TControl.GetWrapper() before TControl.Foo() ever gets a chance to invoke the Foo() method of that object. In this particular example, it is OK since none of the Foo() methods access any object member fields, but once you start doing that in actual production code, it is likely to crash. You need to keep the T(A/B/C) object alive until you are done using the TNotifyEventWrapper object.
I have tested my own class with the dependency injection and now I have to implement it into production. The following is an excerpt of my class and relevant interface:
ITableDB = interface
['{171DE959-8604-4CD3-ACEA-ACCE15E95621}']
procedure Close;
procedure Open;
...
end;
TNewStrategy=class(TObject)
private
FTableDB: ITableDB
.....
public
constructor Create (ATableDB: ITableDB....)
end;
Instead of mocks and stubs I have to provide the class the real objects now. These are a number of third part components I have placed in a form at design time. Here one example:
type
TForm1 = class(TForm)
ThirdyPartDBTable1: ThirdyPartDBTable;
NewStrategy: TNewStrategy;
private
{ Private declarations }
public
{ Public declarations }
end;
How can I pass ThirdyPartDBTable1 to TNewStrategy.Create ? I tried the following code:
TMyThirdyPartDBTable = class(ThirdyPartDBTable, IITableDB)
public
procedure Close;
procedure Open;
...
end;
But when I try to change ThirdyPartDBTable1: ThirdyPartDBTable into ThirdyPartDBTable1: TMYhirdyPartDBTable; the compiler changes the reference TMYhirdyPartDBTable back to ThirdyPartDBTable.
In the code you showed, TNewStrategy is not derived from TComponent, so it cannot be placed on a TForm at design-time. You would have to create it at run-time, in which case you have access to its constructor and can pass ThirdyPartDBTable1 to it, eg:
procedure TForm1.FormCreate(Sender: TObject);
begin
NewStrategy := TNewStrategy.Create(ThirdyPartDBTable1);
end;
However, if TNewStrategy were a TComponent descendant available at design-time, you could link ThirdyPartDBTable1 to NewStrategy at design-time if you change TNewStrategy to expose an ITableDB property instead of passing it in the constructor, eg:
TNewStrategy = class(TComponent)
private
FTableDB: ITableDB
.....
public
constructor Create(AOwner: TComponent); override;
published
property TableDB: ITableDB read FTableDB write FTableDB;
end;
As long as ThirdyPartDBTable implements ITableDB then the Object Inspector and DFM streaming will allow it.
Update: since ThirdPartyDBTable does not implement ITableDB, you can use an interceptor class to implement it, eg:
interface
uses
..., ThirdPartyUnit;
type
ThirdyPartDBTable = class(ThirdPartyUnit.ThirdyPartDBTable, ITableDB)
public
procedure Close;
procedure Open;
end;
TForm1 = class(TForm)
ThirdyPartDBTable1: ThirdyPartDBTable;
NewStrategy: TNewStrategy;
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
implementation
procedure ThirdyPartDBTable.Close;
begin
...
end;
procedure ThirdyPartDBTable.Open;
begin
...
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
NewStrategy := TNewStrategy.Create(ThirdyPartDBTable1 as ITableDB);
end;
end.
You cannot change the class of a component that you've put at design time by modifying it in the form declaration, the IDE owns the declarations in the upper public part of the form.
You can create your derived component at run time instead, or install it in a run time package and register with the component library. For a single time job, or for testing purposes, you can use an interposer class. In the below example I used a TPanel since I don't have any ThirdyPartDBTable, so be sure to put a panel on the test form. Also omitted the 'Close' method for brevity.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
ITableDB = interface
['{171DE959-8604-4CD3-ACEA-ACCE15E95621}']
procedure Open;
end;
TPanel = class(extctrls.TPanel, ITableDB)
public
procedure Open;
end;
TNewStrategy=class(TObject)
private
FTableDB: ITableDB;
public
constructor Create(ATableDB: ITableDB);
end;
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
private
NewStrategy: TNewStrategy;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TPanel }
procedure TPanel.Open;
begin
ShowMessage('Open what?');
end;
{ TNewStrategy }
constructor TNewStrategy.Create(ATableDB: ITableDB);
begin
FTableDB := ATableDB;
end;
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
NewStrategy := TNewStrategy.Create(Panel1 as ITableDB);
NewStrategy.FTableDB.Open;
end;
end.
I created my own component (it like a button which can move) in Delphi, installed it. Then I create a new project and new from there and added few new my component elements. But only last one added is able to move! Others not. Why does it happen? How could I fix it?
Here's the component code:
unit ModifiedButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
var Timer: TTimer;
type
TSpeed = (Slow,Normal,Fast);
TModifiedButton = class(TButton)
private
{ Private declarations }
FCount:integer;
Velocity:integer;
FSpeed:TSpeed;
protected
{ Protected declarations }
procedure Click;override;
procedure Move(Vel:Integer);
procedure OnTimer(Sender: TObject);
public
{ Public declarations }
procedure ShowCount;
published
{ Published declarations }
property Count:integer read FCount write FCount;
property Speed: TSpeed read FSpeed write FSpeed;
constructor Create(aowner:Tcomponent); override;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('MyComponents', [TModifiedButton]);
end;
{ TModifiedButton }
procedure TModifiedButton.Click;
begin
inherited Click;
FCount:=FCount+1;
if (Speed = Slow) then
Velocity:=2;
if (Speed = Normal) then
Velocity:=10;
if (Speed = Fast) then
Velocity:= 20;
Timer.Enabled:=True;
end;
constructor TModifiedButton.Create(aowner: Tcomponent);
begin
inherited Create(aowner);
Timer:=TTimer.Create(self);
Timer.Enabled:=false;
Timer.OnTimer:=OnTimer;
Timer.Interval:=10;
end;
procedure TModifiedButton.Move(Vel: Integer);
begin
Left:=Left + Vel;
end;
procedure TModifiedButton.OnTimer(Sender: TObject);
begin
Move(Velocity);
end;
procedure TModifiedButton.ShowCount;
begin
ShowMessage('You cliked '+ caption+' for '+inttostr(FCount)+' times');
end;
end
.
Since the Timer is a global variable, each new button you create will overwrite the OnTimer event handler of the previous button. Solution, make the Timer a member of your TModifiedButton class:
unit ModifiedButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TSpeed = (Slow,Normal,Fast);
TModifiedButton = class(TButton)
private
{ Private declarations }
FCount:integer;
Velocity:integer;
FSpeed:TSpeed;
Timer: TTimer;
protected
{ Protected declarations }
procedure Click;override;
procedure Move(Vel:Integer);
procedure OnTimer(Sender: TObject);
public
{ Public declarations }
procedure ShowCount;
published
{ Published declarations }
property Count:integer read FCount write FCount;
property Speed: TSpeed read FSpeed write FSpeed;
constructor Create(aowner:Tcomponent); override;
destructor Destroy; override;
end;
procedure Register;
implementation
{ TModifiedButton }
procedure TModifiedButton.Click;
begin
inherited Click;
FCount:=FCount+1;
Case Speed of
Slow : Velocity:=2;
Normal : Velocity:=10;
Fast : Velocity:= 20;
end;
Timer.Enabled:=True;
end;
procedure TModifiedButton.Move(Vel: Integer);
begin
Left:=Left + Vel;
end;
procedure TModifiedButton.OnTimer(Sender: TObject);
begin
Move(Velocity);
end;
procedure TModifiedButton.ShowCount;
begin
ShowMessage(Format('You clicked %s for %d times', [Caption, FCount]));
end;
constructor TModifiedButton.Create(AOwner: Tcomponent);
begin
inherited Create(AOwner);
Timer := TTimer.Create(self);
Timer.Enabled:=false;
Timer.OnTimer:=OnTimer;
Timer.Interval:=10;
end;
destructor Destroy;
begin
Timer.Enabled := False;
Timer.Free;
end;
procedure Register;
begin
RegisterComponents('MyComponents', [TModifiedButton]);
end;
end.
What is the best solution to show that the application is doing something?
I tried showing a progress indicator, but it did not work.
UPDATE: -------------
A progress bar works fine, but isn't what I want.
I want to show a throbber, like what Web browsers use, so as long as something is being updated it keeps turning.
Cursor can also be in crHourGlass mode.
Try this:
AnimateUnit
unit AnimateUnit;
interface
uses
Windows, Classes;
type
TFrameProc = procedure(const theFrame: ShortInt) of object;
TFrameThread = class(TThread)
private
{ Private declarations }
FFrameProc: TFrameProc;
FFrameValue: ShortInt;
procedure SynchedFrame();
protected
{ Protected declarations }
procedure Frame(const theFrame: ShortInt); virtual;
public
{ Public declarations }
constructor Create(theFrameProc: TFrameProc; CreateSuspended: Boolean = False); reintroduce; virtual;
end;
TAnimateThread = class(TFrameThread)
private
{ Private declarations }
protected
{ Protected declarations }
procedure Execute(); override;
public
{ Public declarations }
end;
var
AnimateThread: TAnimateThread;
implementation
{ TFrameThread }
constructor TFrameThread.Create(theFrameProc: TFrameProc; CreateSuspended: Boolean = False);
begin
inherited Create(CreateSuspended);
FreeOnTerminate := True;
FFrameProc := theFrameProc;
end;
procedure TFrameThread.SynchedFrame();
begin
if Assigned(FFrameProc) then FFrameProc(FFrameValue);
end;
procedure TFrameThread.Frame(const theFrame: ShortInt);
begin
FFrameValue := theFrame;
try
Sleep(0);
finally
Synchronize(SynchedFrame);
end;
end;
{ TAnimateThread }
procedure TAnimateThread.Execute();
var
I: ShortInt;
begin
while (not Self.Terminated) do
begin
Frame(0);
for I := 1 to 8 do
begin
if (not Self.Terminated) then
begin
Sleep(120);
Frame(I);
end;
end;
Frame(0);
end;
end;
end.
Unit1
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, ImgList;
type
TForm1 = class(TForm)
ImageList1: TImageList;
Image1: TImage;
Button1: TButton;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure UpdateFrame(const theFrame: ShortInt);
end;
var
Form1: TForm1;
implementation
uses
AnimateUnit;
{$R *.DFM}
procedure TForm1.UpdateFrame(const theFrame: ShortInt);
begin
Image1.Picture.Bitmap.Handle := 0;
try
ImageList1.GetBitmap(theFrame, Image1.Picture.Bitmap);
finally
Image1.Update();
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
AnimateThread := TAnimateThread.Create(UpdateFrame);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
AnimateThread.Terminate();
end;
end.
The Images
You are probably running your time consuming task in the main thread.
One option is to move it to a background thread which will allow your message queue to be serviced. You need it to be serviced in order for your progress bar, and indeed any UI, to work.
Answer to the updated question:
generate an animated gif e.g. here
add a GIF library to your environment (JEDI JVCL+JCL)
insert a TImage and load the generated gif
make it visible if you need it
A indicator is OK. You have to call Application.ProcessMessages after changing it.
"What is the best solution to show that that application is doing something?" - set mouse cursor to crHourGlass? or to create another form/frame/etc which attentions the user that the application is 'doing' something, and he needs to wait.
From your lengthy task, you can occasionally update a visual indicator, like a progress bar or anything else. However, you need to redraw the changes immediately by calling Update on the control that provides the feedback.
Don't use Application.ProcessMessages as this will introduce possible reentrancy issues.