Delphi的接口委托示例

{
  说明：该事例实现的效果，在单个应用或代码量小的项目中，可以完全不用接口委托来完成。
  之所以采用委托接口，主要是应用到：已经实现的接口模块中，在不改变原有代码的情况下，
  需要对其进行扩展；原始模块只需要开放部分功能，但又不能暴露实现细节的场合；
}

unit TestUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
  TestMsgGUID: TGUID = '{4BE80D5E-D94B-42BE-9114-077DC2708451}';

type
  //原始接口中新增需要暴露给其它模块的接口定义，公用部分
  ITestMsg = interface
    ['{4BE80D5E-D94B-42BE-9114-077DC2708451}']
    procedure ShowTestMsg;
  end;

//---------------------------------服务模块
  //基类对象，只需要开放ShowTestMsg方法给外部，所以做为按口的实现基类
  TBaseTestMsg = class(TInterfacedObject, ITestMsg)
  public
    //.... 模块已存在的老代码....

//新开放的接口代码方法
    procedure ShowTestMsg; virtual;     //申明成虚拟方法，以便继承类可以重载
  end;

//---------------------------------接口委托对象定义
  TTestMsgClass = class(TInterfacedObject, ITestMsg)
  private
    FTestMsg: ITestMsg;
  public
    property Service: ITestMsg read FTestMsg implements ITestMsg;

constructor Create(AClass: TClass);
    constructor CreateEx(AClass: TClass);      //另一种用法, 不采用TBaseTestMsg做为基类创建委托实例
    destructor Destroy; override;
  end;

//----------------------------------外部引用的业务模块
  //完成具体业务的委托实例
  TETestMsg = class(TInterfacedObject, ITestMsg)
  public
    procedure ShowTestMsg;
  end;

//完成具体业务的委托实例
  TCTestMsg = class(TInterfacedObject, ITestMsg)
  public
    procedure ShowTestMsg;
  end;

TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure DoTest(AClass: TClass; ACreateEx: Boolean = False);     //测试方法
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TBaseTestMsg }

procedure TBaseTestMsg.ShowTestMsg;
begin
end;

{ TTestMsgClass }

constructor TTestMsgClass.Create(AClass: TClass);
var
  vObj: TBaseTestMsg;
begin
  vObj := TBaseTestMsg(AClass.NewInstance);
  FTestMsg := vObj.Create;
end;

constructor TTestMsgClass.CreateEx(AClass: TClass);
begin
  //该方法不采用TBaseTestMsg做为基类创建委托实例，更通用更灵活
  (AClass.NewInstance.Create).GetInterface(TestMsgGUID, FTestMsg);
end;

destructor TTestMsgClass.Destroy;
begin
  FTestMsg := nil;
  inherited;
end;

{ TETestMsg }

procedure TETestMsg.ShowTestMsg;
begin
  ShowMessage('TETestMsg Msg:' + 'OK');
end;

{ TCTestMsg }

procedure TCTestMsg.ShowTestMsg;
begin
  ShowMessage('TCTestMsg 消息:' + '好的');
end;

//--------------------以下为测试代码--------------------------------

procedure TForm1.DoTest(AClass: TClass; ACreateEx: Boolean);
var
  vClass: TTestMsgClass;
  vTest: ITestMsg;
begin
  if ACreateEx then
    vClass := TTestMsgClass.CreateEx(AClass)
  else
    vClass := TTestMsgClass.Create(AClass);

try
    vTest := vClass;
    vTest.ShowTestMsg;
  finally
    vTest := nil;
    FreeAndNil(vClass);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DoTest(TETestMsg);
  DoTest(TCTestMsg);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DoTest(TETestMsg, True);
  DoTest(TCTestMsg, True);
end;

end.