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;     //申明成虛拟方法，以便繼承類可以重載

  //---------------------------------接口委托對象定義

  TTestMsgClass = class(TInterfacedObject, ITestMsg)

  private

    FTestMsg: ITestMsg;

    property Service: ITestMsg read FTestMsg implements ITestMsg;

    constructor Create(AClass: TClass);

    constructor CreateEx(AClass: TClass);      //另一種用法, 不采用TBaseTestMsg做為基類建立委托執行個體

    destructor Destroy; override;

  //----------------------------------外部引用的業務子產品

  //完成具體業務的委托執行個體

  TETestMsg = class(TInterfacedObject, ITestMsg)

  TCTestMsg = class(TInterfacedObject, ITestMsg)

  TForm1 = class(TForm)

    Button1: TButton;

    Button2: TButton;

    procedure Button1Click(Sender: TObject);

    procedure Button2Click(Sender: TObject);

    { Private declarations }

    { Public declarations }

    procedure DoTest(AClass: TClass; ACreateEx: Boolean = False);     //測試方法

var

  Form1: TForm1;

implementation

{$R *.dfm}

{ TBaseTestMsg }

procedure TBaseTestMsg.ShowTestMsg;

begin

end;

{ TTestMsgClass }

constructor TTestMsgClass.Create(AClass: TClass);

  vObj: TBaseTestMsg;

  vObj := TBaseTestMsg(AClass.NewInstance);

  FTestMsg := vObj.Create;

constructor TTestMsgClass.CreateEx(AClass: TClass);

  //該方法不采用TBaseTestMsg做為基類建立委托執行個體，更通用更靈活

  (AClass.NewInstance.Create).GetInterface(TestMsgGUID, FTestMsg);

destructor TTestMsgClass.Destroy;

  FTestMsg := nil;

  inherited;

{ TETestMsg }

procedure TETestMsg.ShowTestMsg;

  ShowMessage('TETestMsg Msg:' + 'OK');

{ TCTestMsg }

procedure TCTestMsg.ShowTestMsg;

  ShowMessage('TCTestMsg 消息:' + '好的');

//--------------------以下為測試代碼--------------------------------

procedure TForm1.DoTest(AClass: TClass; ACreateEx: Boolean);

  vClass: TTestMsgClass;

  vTest: ITestMsg;

  if ACreateEx then

    vClass := TTestMsgClass.CreateEx(AClass)

  else

    vClass := TTestMsgClass.Create(AClass);

  try

    vTest := vClass;

    vTest.ShowTestMsg;

  finally

    vTest := nil;

    FreeAndNil(vClass);

procedure TForm1.Button1Click(Sender: TObject);

  DoTest(TETestMsg);

  DoTest(TCTestMsg);

procedure TForm1.Button2Click(Sender: TObject);

  DoTest(TETestMsg, True);

  DoTest(TCTestMsg, True);

end.