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.