fmmain.pas

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

unit fmMain;

interface

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

type

//  IMyInterface= interface(IUnknown)
//    ['{565F2132-F079-4126-95B5-151BBA70D8A1}']
//    function GetInterfaceAge: Integer; stdcall;
//    function GetName: String; stdcall;
//  end;
{
  TMyObject = class(TObject, IMyInterface)
  private
    FRefCount : Integer;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
  public
    //IUnknown interface
    function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;

    //IMyInterface
    function GetInterfaceAge: Integer; stdcall;
    function GetName: String; stdcall;
    function GetRC : Integer;
  end;
}
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    ListBox1: TListBox;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses ComObj;

{ TMyObject }
{

function TMyObject.GetInterfaceAge: Integer;
begin
  Result := 1000;
end;

function TMyObject.GetName: String;
begin
  Result := 'IMyInterface';
end;

function TMyObject._AddRef: Integer;
begin
  Result := InterlockedIncrement(FRefCount);
end;

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

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

function TMyObject.GetRC: Integer;
begin
  Result := Self.FRefCount;
end;
}

procedure TForm1.Button1Click(Sender: TObject);
var
  aIntf : IMyInterface;
  iRoot : IUnknown;
  iAge : Integer;
  sName : WideString;
begin
  iRoot := CreateCOMObject(CLASS_MyInterface);
  OleCheck(iRoot.QueryInterface(IID_IMyInterface, aIntf) );
  try
    OleCheck(aIntf.GetInterfaceAge(iAge));
    Edit1.Text := IntToStr(iAge);
    OleCheck(aIntf.GetName(sName));
    Edit2.Text := sName;
  finally // wrap up
    aIntf._Release;
    iRoot._Release;
  end;    // try/finally
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  aIntf : IMyInterface;
  iRoot : IUnknown;
  iAge : Integer;
  sName : WideString;
begin
  iRoot := CreateCOMObject(CLASS_MyInterface);
  aIntf := iRoot as IMyInterface;
  try
    OleCheck(aIntf.GetInterfaceAge(iAge));
    Edit1.Text := IntToStr(iAge);
    OleCheck(aIntf.GetName(sName));
    Edit2.Text := sName;
  finally // wrap up
    aIntf._Release;
    iRoot._Release;
  end;    // try/finally
end;

procedure TForm1.Button3Click(Sender: TObject);
var
  aIntf : IMyInterface;
  iRoot : IUnknown;
  iAge : Integer;
  sName : WideString;
begin
  iRoot := CreateCOMObject(CLASS_MyInterface);
  aIntf := IMyInterface(iRoot);
  try
    OleCheck(aIntf.GetInterfaceAge(iAge));
    Edit1.Text := IntToStr(iAge);
    OleCheck(aIntf.GetName(sName));
    Edit2.Text := sName;
  finally // wrap up
    aIntf._Release;
    iRoot._Release;
  end;    // try/finally
end;

procedure TForm1.Button4Click(Sender: TObject);
var
  I: Integer;
  aIntf : IMyInterface;
  iRoot : IUnknown;
  iAge : Integer;
  sName : WideString;
  iCount : Integer;
  idx : Integer;
  vGUIDs : OleVariant;
begin
  iRoot := CreateCOMObject(CLASS_MyInterface);
  aIntf := IMyInterface(iRoot);
  try
    aIntf.GetInterfaceCount(iCount);
    ListBox1.Items.Add('COM对象共有 : ' + IntToStr(iCount) + ' 个接口');
    aIntf.GetAllInterfaces(vGUIDs);
    if (VarIsArray(vGUIDs)) then
    begin
      for idx := VarArrayLowBound(vGUIDs, 1) to VarArrayHighBound(vGUIDs, 1) do    // Iterate
      begin
        ListBox1.Items.Add(vGUIDs[idx]);
      end;    // for
    end;
  finally // wrap up
    aIntf._Release;
    iRoot._Release;
  end;    // try/finally
end;

end.