-
-
Save ortuagustin/7d782d874a63c675091e48ba612c6176 to your computer and use it in GitHub Desktop.
Delphi / TFormAsInterface
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
program Test003; | |
uses | |
FastMM4 in '..\..\..\VCL\FastMM4\FastMM4.pas', | |
FastMM4Messages in '..\..\..\VCL\FastMM4\FastMM4Messages.pas', | |
Vcl.Forms, | |
Unit1 in 'Unit1.pas' {Form1}, | |
Unit2 in 'Unit2.pas' {Form2}, | |
Unit3 in 'Unit3.pas'; | |
{$R *.res} | |
begin | |
Application.Initialize; | |
Application.MainFormOnTaskbar := True; | |
Application.CreateForm(TForm1, Form1); | |
Application.Run; | |
end. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
object Form1: TForm1 | |
Left = 0 | |
Top = 0 | |
Caption = 'Form1' | |
ClientHeight = 290 | |
ClientWidth = 554 | |
Color = clBtnFace | |
Font.Charset = DEFAULT_CHARSET | |
Font.Color = clWindowText | |
Font.Height = -11 | |
Font.Name = 'Tahoma' | |
Font.Style = [] | |
OldCreateOrder = False | |
PixelsPerInch = 96 | |
TextHeight = 13 | |
object Button1: TButton | |
Left = 124 | |
Top = 64 | |
Width = 75 | |
Height = 25 | |
Caption = 'Button1' | |
TabOrder = 0 | |
OnClick = Button1Click | |
end | |
end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
unit Unit1; | |
interface | |
uses | |
Unit3, | |
// | |
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; | |
procedure Button1Click(Sender: TObject); | |
private | |
public | |
end; | |
var | |
Form1: TForm1; | |
implementation | |
{$R *.dfm} | |
uses | |
Unit2; | |
procedure TForm1.Button1Click(Sender: TObject); | |
var | |
LForm2: IForm2; | |
begin | |
LForm2 := CreateForm2(Self); | |
try | |
LForm2.CallbackProc; | |
finally | |
LForm2 := nil; | |
end; | |
end; | |
end. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
object Form2: TForm2 | |
Left = 0 | |
Top = 0 | |
Caption = 'Form2' | |
ClientHeight = 290 | |
ClientWidth = 554 | |
Color = clBtnFace | |
Font.Charset = DEFAULT_CHARSET | |
Font.Color = clWindowText | |
Font.Height = -11 | |
Font.Name = 'Tahoma' | |
Font.Style = [] | |
OldCreateOrder = False | |
PixelsPerInch = 96 | |
TextHeight = 13 | |
end |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
unit Unit2; | |
interface | |
uses | |
Unit3, | |
// | |
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, | |
Vcl.Controls, Vcl.Forms, Vcl.Dialogs; | |
type | |
IForm2 = interface(ICallbackForm) | |
['{D0204F6D-3F49-4B48-9105-0FB291CD72B3}'] | |
end; | |
TForm2 = class(TForm, IInterface, IForm2) | |
strict private | |
FOwnerIsComponent: Boolean; | |
FRefCount: Integer; | |
protected | |
function _AddRef: Integer; stdcall; | |
function _Release: Integer; stdcall; | |
public | |
class function NewInstance: TObject; override; | |
destructor Destroy; override; | |
public | |
procedure AfterConstruction; override; | |
procedure BeforeDestruction; override; | |
public | |
procedure CallbackProc; | |
end; | |
function CreateForm2(AOwner: TComponent): IForm2; | |
implementation | |
{$R *.dfm} | |
function CreateForm2(AOwner: TComponent): IForm2; | |
begin | |
Result := TForm2.Create(AOwner); | |
end; | |
{ TForm2 } | |
destructor TForm2.Destroy; | |
begin | |
ShowMessage('TForm2.Destroy'); | |
Destroying; | |
if FOwnerIsComponent and (FRefCount > 1) then | |
begin | |
// | |
end; | |
inherited; | |
end; | |
function TForm2._AddRef: Integer; | |
begin | |
Result := InterlockedIncrement(FRefCount) | |
end; | |
function TForm2._Release: Integer; | |
begin | |
Result := InterlockedDecrement(FRefCount); | |
if (Result = 0) then | |
begin | |
if FOwnerIsComponent then | |
Owner.RemoveComponent(Self); | |
Destroy; | |
end; | |
end; | |
class function TForm2.NewInstance: TObject; | |
begin | |
Result := inherited NewInstance; | |
TForm2(Result).FRefCount := 1; | |
end; | |
procedure TForm2.AfterConstruction; | |
begin | |
FOwnerIsComponent := Assigned(Owner) and (Owner is TComponent); | |
InterlockedDecrement(FRefCount); | |
inherited; | |
end; | |
procedure TForm2.BeforeDestruction; | |
{$ifdef DEBUG} | |
var | |
WarningMessage: string; | |
{$endif DEBUG} | |
begin | |
if (FRefCount <> 0) then | |
begin | |
if not FOwnerIsComponent then | |
System.Error(reInvalidPtr) | |
{$ifdef DEBUG} | |
else | |
begin | |
WarningMessage := Format( | |
'Trying to destroy an Owned TForm2 of class %s named %s that still has %d interface references left', | |
[ClassName, Name, FRefCount]); | |
OutputDebugString(PChar(WarningMessage)); | |
end; | |
{$endif DEBUG} | |
end; | |
inherited; | |
end; | |
procedure TForm2.CallbackProc; | |
begin | |
ShowMessage('CallbackProc'); | |
end; | |
end. |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
unit Unit3; | |
interface | |
uses | |
System.Classes, | |
Vcl.Forms; | |
type | |
ICallbackForm = interface(IInterfaceComponentReference) | |
['{59080B84-94C6-4572-9120-6722FC78758A}'] | |
procedure CallbackProc; | |
end; | |
implementation | |
end. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment