Собираем тестовый пример
01.01.2007
Теперь, давайте соберем код. Прошу учесть, что практически не делается никаких проверок - это демонстрационный код. Но работающий.
В начале код dll c объектом.
library CalcDll; uses SysUtils, Classes; type HResult=Longint; ICalcBase=interface //чисто абстрактный интерфейс procedure SetOperands(x,y:integer); procedure Release; end; ICalc=interface(ICalcBase) ['{149D0FC0-43FE-11D6-A1F0-444553540000}'] function Sum:integer; function Diff:integer; end; ICalc2=interface(ICalcBase) ['{D79C6DC0-44B9-11D6-A1F0-444553540000}'] function Mult:integer; function Divide:integer; end; MyCalc=class(TObject,ICalc,ICalc2) //два интерфейса fx,fy:integer; public procedure SetOperands(x,y:integer); function Sum:integer; function Diff:integer; function Divide:integer; function Mult:integer; procedure Release; function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; function _AddRef:Longint; stdcall; function _Release:Longint; stdcall; end; const S_OK = 0; E_NOINTERFACE = HRESULT($80004002); procedure MyCalc.SetOperands(x,y:integer); begin fx:=x; fy:=y; end; function MyCalc.Sum:integer; begin result:=fx+fy; end; function MyCalc.Diff:integer; begin result:=fx-fy; end; function MyCalc.Divide:integer; begin result:=fx div fy; end; function MyCalc.Mult:integer; begin result:=fx*fy; end; procedure MyCalc.Release; begin Free; end; function MyCalc.QueryInterface(const IID: TGUID; out Obj): HResult; begin if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; end; function MyCalc._AddRef; begin end; function MyCalc._Release; begin end; procedure CreateObject(const IID: TGUID; var ACalc); var Calc:MyCalc; begin Calc:=MyCalc.Create; if not Calc.GetInterface(IID,ACalc) then Calc.Free; end; exports CreateObject; begin end.
А теперь тестер.
unit tstcl; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls,ComObj; type //обратите внимание! Используем один унифицированный интерфейс IUniCalc=interface procedure SetOperands(x,y:integer); procedure Release; function Sum:integer; function Diff:integer; end; TForm1 = class(TForm) Button1: TButton; Button2: TButton; Button3: TButton; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); procedure Button3Click(Sender: TObject); end; var Form1: TForm1; _Mod:Integer; //хэндл модуля СreateObject:procedure (IID:TGUID; out Obj); //процедура из dll. Calc:IUniCalc; //это указатель на интерфейс котрый мы будем получать ICalcGUID:TGUID; ICalc2GUID:TGUID; flag:boolean; // какой интерфейс активный. implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin _Mod:=LoadLibrary(PChar('C:\Kir\COM\SymplDll\CalcDll.dll')); //Эти GUID я просто скопировал из исходника CalcDll.dll ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}'); ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}'); flag:=true; СreateObject:=GetProcAddress(_Mod,'CreateObject'); СreateObject(ICalcGUID,Calc); if Calc<>nil then Calc.SetOperands(10,5); end; procedure TForm1.FormDestroy(Sender: TObject); begin if Calc<>nil then Calc.Release; FreeLibrary(_Mod); end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage(IntToStr(Calc.diff)); end; procedure TForm1.Button2Click(Sender: TObject); begin ShowMessage(IntToStr(Calc.Sum)); end; procedure TForm1.Button3Click(Sender: TObject); var tmpCalc:IUniCalc; begin if flag then Calc.QueryInterface(ICalc2GUID,tmpCalc) else Calc.QueryInterface(ICalcGUID,tmpCalc); flag:=not flag; Calc:=tmpCalc; end; end.
Обратите вснимание, что происходит при нажатии на кнопку3. Мы используем ту же самую переменную, для работы со вторым интерфейсом! Этот пример показывает, что получая указатель на интерфейс, его методы мы получаем за счет смещения, от адреса который этот указатель содержит. Короче, мы получаем адрес таблицы методов.
Потыкайте, посмотрите что происходит.