Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Delphi / TFormAsInterface
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.
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
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.
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
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.
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