library procserver; { Wichtiger Hinweis zur DLL-Speicherverwaltung: ShareMem muß die erste Unit im Uses-Anweisungsteil des Interface-Abschnitts Ihrer Unit sein, wenn Ihre DLL Prozeduren oder Funktionen exportiert, die String-Parameter oder Funktionsergebnisse übergeben. Dies gilt für alle Strings die an und von Ihrer DLL übergeben werden -- selbst für diese, die in Records oder Klassen verschachtelt sind. ShareMem ist die Schnittstellen-Unit zur DELPHIMM.DLL, welche Sie mit Ihrer DLL weitergeben müssen. Um die Verwendung von DELPHIMM.DLL zu vermeiden, übergeben Sie String-Parameter unter Verwendung von PChar- oder ShortString-Parametern. } uses windows,SysUtils,Classes,registry; type TIID = TGUID; { IClassFactory interface } IClassFactory = interface(IUnknown) ['{00000001-0000-0000-C000-000000000046}'] function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall; function LockServer(fLock: BOOL): HResult; stdcall; end; function uidequal(const id1,id2:tguid):boolean; var i:integer; begin uidequal:=false; if (id1.d1=id2.d1)and(id1.d2=id2.d2)and(id1.d3=id2.d3)then begin for i:=0 to 7 do if id1.d4[i]<>id2.D4[i]then exit; uidequal:=true; end; end; function dllregisterserver:hresult; var r:tregistry; begin r:=tregistry.create; r.rootkey:=hkey_classes_root; r.openKey('CLSID\{12345678-0000-0000-C000-000000000046}\InprocServer32',true); r.writestring('','procserver.dll'); r.free; dllregisterserver:=0; end; type imystackfactory=interface(iclassfactory) ['{12345678-0000-0000-C000-000000000046}'] function QueryInterface(const iid: TIID; out obj): HResult; stdcall; function _AddRef: Longint;stdcall; function _Release: Longint;stdcall; function CreateInstance(const unkOuter: IUnknown; const iid: TIID; out obj): HResult; stdcall; end; tmystackfactory=class(tobject,iunknown,iclassfactory,imystackfactory) { IUnknown } function QueryInterface(const IID: TGUID; out Obj): Hresult; virtual;stdcall; function _AddRef: Integer; virtual;stdcall; function _Release: Integer; virtual;stdcall; { IClassFactory } function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID; out Obj): HResult; virtual;stdcall; function LockServer(fLock: BOOL): HResult; virtual;stdcall; constructor create; end; imystack=interface(iunknown) ['{12345678-0000-0000-C000-000000000047}'] { IUnknown } function QueryInterface(const IID: TGUID; out Obj): hresult; stdcall; function _AddRef: Integer; stdcall; function _Release: Integer; stdcall; function push(const x:integer):hresult;stdcall; function pop(out x:integer):hresult;stdcall; function top(out x:integer):hresult;stdcall; function dump:hresult;stdcall; end; tmystack=class(tobject,iunknown,imystack) a:array[1..10]of integer; n:integer; { IUnknown } function QueryInterface(const IID: TGUID; out Obj): hresult; virtual;stdcall; function _AddRef: Integer; virtual;stdcall; function _Release: Integer; virtual;stdcall; function push(const x:integer):hresult;virtual;stdcall; function pop(out x:integer):hresult;virtual;stdcall; function top(out x:integer):hresult;virtual;stdcall; function dump:hresult;virtual;stdcall; constructor create; end; var factory:tmystackfactory; function tmystackfactory.QueryInterface(const iid: TIID; out obj): HResult; var ppv:pointer absolute obj; begin ppv:=self; queryinterface:=0; end; function tmystackfactory._AddRef: Longint; begin writeln('addref'); _addref:=0; end; function tmystackfactory._Release: Longint; begin writeln('release'); _release:=0; end; function tmystackfactory.CreateInstance(const unkOuter: IUnknown; const iid: TIID;out obj): HResult; var ppv:pointer absolute obj; begin writeln('stackfactory create instance'); ppv:=nil; if uidequal(iid,imystack)then begin ppv:=tmystack.create;result:=0; end else result:=$99; end; function tmystackfactory.LockServer(fLock: BOOL): HResult; begin lockserver:=0; end; constructor tmystackfactory.create; begin writeln('in mycreate'); inherited create; end; function tmystack.QueryInterface(const IID: TGUID; out Obj): hresult; var ppv:pointer absolute obj; begin ppv:=self;queryinterface:=0; end; function tmystack._AddRef: Longint; begin _addref:=0; end; function tmystack._Release: Longint; begin _release:=0; end; constructor tmystack.create; begin writeln('tmystack create'); inherited create; n:=0; end; function tmystack.push(const x:integer):hresult; begin writeln('in push'); if n=10 then result:=1 else begin inc(n);a[n]:=x;result:=0; end; writeln('ende push N=',n,' n[1]=',a[1]); end; function tmystack.pop(out x:integer):hresult; begin writeln('in pop N=',n,' n[1]=',a[1]); if n=0 then result:=1 else begin x:=a[n];dec(n);result:=0; end; end; function tmystack.top(out x:integer):hresult; begin writeln('in top N=',n,' n[1]=',a[1]); if n=0 then result:=1 else begin x:=a[n];result:=0; end; end; function tmystack.dump:hresult;stdcall; var i:integer; begin writeln('dump ',inttohex(integer(@self),10)); for i:=1 to n do write(a[i],' '); writeln; dump:=0; end; function DllGetClassObject(const CLSID, IID: TGUID; out Obj): HResult;stdcall; var ppv:pointer absolute obj; begin writeln('nun in dllgetclassobject'); ppv:=factory; result:=0; writeln('dllget ppv=',inttohex(integer(ppv),10)); end; exports dllregisterserver; exports dllgetclassobject; begin factory:=tmystackfactory.create; writeln('init factory=',inttohex(integer(factory),10)); end.