udelegateclass.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

unit uDelegateClass;

interface

uses SysUtils, uInterfaces, Windows;

type
  TImplClass = class(TObject, IImplInterface)
  private
    FRefCount : Integer;
    FOwner : Boolean;

    FUSDRate : Double;
    FRMBRate : Double;

    function GetUSDRate : Double; stdcall;
    function GetRMBRate : Double; stdcall;
    procedure SetUSDRate(const dRate : Double); stdcall;
    procedure SetRMBRate(const dRate : Double); stdcall;
  public
    //IInterface
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;

    function ConvertToUSD(const iNTD : Integer) : Double; stdcall;
    function ConvertToRMB(const iNTD : Integer) : Double; stdcall;

    Constructor Create(Owner : Boolean); 
    Destructor Destroy; override;
    property Owner : Boolean read FOwner write FOwner;
  end;

  TIntfServiceClass = class(TObject, IImplInterface)
  private
    FImplService: IImplInterface;
  public
    Constructor Create; overload;
    Destructor Destroy; override;
    Constructor Create(aClass : TClass); overload;
    property MyService : IImplInterface read FImplService implements IImplInterface;
  end;

  TClsServiceClass = class(TObject, IImplInterface)
  private
    FSrvObj : TImplClass;
  public
    Constructor Create; overload;
    Destructor Destroy; override;
    Constructor Create(aClass : TClass); overload;
    property MyService : TImplClass read FSrvObj implements IImplInterface;
  end;

implementation

uses fmMain;

{ TImplClass }

const
  INTFGUID : TGUID = '{7B7840DC-97AD-48AD-80EE-ECFD78B511A0}';

function TImplClass.ConvertToRMB(const iNTD: Integer): Double;
begin
  Result := iNTD / FRMBRate;
end;

function TImplClass.ConvertToUSD(const iNTD: Integer): Double;
begin
  Result := iNTD / FUSDRate;
end;

function TImplClass._AddRef: Integer;
begin
  if (FRefCount = 0) then
  begin
    FUSDRate := 34.8;
    FRMBRate := 4.05;
  end;
  Result := InterlockedIncrement(FRefCount);
end;

function TImplClass._Release: Integer;
begin
  Result := InterlockedDecrement(FRefCount);
  if Result = 0 then
    if (not FOwner) then
      Destroy;
end;

function TImplClass.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
  if GetInterface(IID, Obj) then
    Result := 0
  else
    Result := E_NOINTERFACE;
end;

destructor TImplClass.Destroy;
begin
  Form1.AppMsg('TImplClass对象在 ' + DateToStr(Now) + ' 被释放!');
  inherited;
end;

constructor TImplClass.Create(Owner: Boolean);
begin
  FOwner := Owner;
end;

function TImplClass.GetRMBRate: Double;
begin
  Result := FRMBRate;
end;

function TImplClass.GetUSDRate: Double;
begin
  Result := FUSDRate;
end;

procedure TImplClass.SetRMBRate(const dRate: Double);
begin
  FRMBRate := dRate;
end;

procedure TImplClass.SetUSDRate(const dRate: Double);
begin
  FUSDRate := dRate;
end;

{ TIntfServiceClass }

constructor TIntfServiceClass.Create;
begin
  FImplService := TImplClass.Create(False);
end;

constructor TIntfServiceClass.Create(aClass: TClass);
//var
//  Instance : TImplClass;
begin
//  Instance := TImplClass(aClass.NewInstance);
//  FImplService := Instance.Create;

   (aClass.NewInstance.Create).GetInterface(INTFGUID, FImplService);
end;

destructor TIntfServiceClass.Destroy;
begin
  FImplService := nil;
  inherited;
end;

{ TClsServiceClass }

constructor TClsServiceClass.Create;
begin
  FSrvObj := TImplClass.Create(True);
end;

constructor TClsServiceClass.Create(aClass: TClass);
//var
//  Instance : TImplClass;
begin
//  Instance := TImplClass(aClass.NewInstance);
//  FSrvObj := Instance.Create;

  FSrvObj := TImplClass(aClass.NewInstance.Create);
  FSrvObj.Owner := True;
end;

destructor TClsServiceClass.Destroy;
begin
  FreeAndNil(FSrvObj);
  inherited;
end;

end.