unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls;
type
{$Interfaces CORBA}
IbtnSwapable = interface['IbtnSwapable']
function get_Caption: string;
function get_Hint: string;
function get_OnClick: TNotifyEvent;
function get_Parent: TWinControl;
function Obj: TObject;
procedure set_Caption(aValue: string);
procedure set_Hint(aValue: string);
procedure set_OnClick(aValue: TNotifyEvent);
procedure set_Parent(aValue: TWinControl);
property Caption: string read get_Caption write set_Caption;
property Hint: string read get_Hint write set_Hint;
property OnClick: TNotifyEvent read get_OnClick write set_OnClick;
property Parent: TWinControl read get_Parent write set_Parent;
end;
{$Interfaces COM}
{ TbtnSwapableLCL }
TbtnSwapableLCL = class(TCustomButton,IbtnSwapable)
private
function get_Caption: string;
function get_Hint: string;
function get_OnClick: TNotifyEvent;
function get_Parent: TWinControl;
function Obj: TObject;
procedure set_Caption(aValue: string);
procedure set_Hint(aValue: string);
procedure set_OnClick(aValue: TNotifyEvent);
procedure set_Parent(aValue: TWinControl);
published
property Caption: string read get_Caption write set_Caption;
property Hint: string read get_Hint write set_Hint;
property OnClick: TNotifyEvent read get_OnClick write set_OnClick;
property Parent: TWinControl read get_Parent write set_Parent;
end;
{ TForm1 }
TForm1 = class(TForm)
Button1: TButton;
procedure IntfBtnClick(aSender: TObject);
private
public
btnIntf: IbtnSwapable;
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TbtnSwapableLCL }
function TbtnSwapableLCL.get_Caption: string;
begin
Result:= inherited Caption;
end;
function TbtnSwapableLCL.get_Hint: string;
begin
Result:= inherited Hint;
end;
function TbtnSwapableLCL.get_OnClick: TNotifyEvent;
begin
Result:= inherited OnClick;
end;
function TbtnSwapableLCL.get_Parent: TWinControl;
begin
Result:= inherited Parent;
end;
function TbtnSwapableLCL.Obj: TObject;
begin
Result:= Self;
end;
procedure TbtnSwapableLCL.set_Caption(aValue: string);
begin
inherited Caption:= aValue;
end;
procedure TbtnSwapableLCL.set_Hint(aValue: string);
begin
inherited Hint:= aValue;
end;
procedure TbtnSwapableLCL.set_OnClick(aValue: TNotifyEvent);
begin
inherited OnClick:= aValue;
end;
procedure TbtnSwapableLCL.set_Parent(aValue: TWinControl);
begin
inherited Parent:= aValue;
end;
{ TForm1 }
procedure TForm1.IntfBtnClick(aSender: TObject);
begin
ShowMessage('Hi HAJ :o)');
end;
procedure TForm1.AfterConstruction;
begin
inherited AfterConstruction;
btnIntf:= TbtnSwapableLCL.Create(nil);
btnIntf.Caption:= '>ME<';
btnIntf.Parent:= Self;
btnIntf.OnClick:= @IntfBtnClick;
end;
procedure TForm1.BeforeDestruction;
begin
btnIntf.Obj.Free;
inherited BeforeDestruction;
end;
end.