paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 09:09:30 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ TTypedComObject

Browse Source 
+ skeleton for TTypedComObjectFactory

git-svn-id: trunk@10711 -
This commit is contained in:
florian 2008-04-19 09:34:00 +00:00
parent 4e7e0f620a
commit 92b16f8876
2 changed files with 61 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
packages/winunits-base/src/activex.pp
View File

@ -3094,14 +3094,16 @@ TYPE
POleMenuGroupWidths = LPOLEMENUGROUPWIDTHS;
IProvideClassInfo = Interface (IUnknown)
['{B196B283-BAB4-101A-B69C-00AA00341D07}']
function GetClassInfo(out pptti : ITypeInfo):HResult; StdCall;
end;
IProvideClassInfo2 = Interface (IProvideClassInfo)
['{A6BC3AC0-DBAA-11CE-9DE3-00AA004BB851}']
function GetGUID(dwguid:DWord;out pguid:TGUID):HResult; StdCall;
end;
IProvideClassInfo = Interface (IUnknown)
['{B196B283-BAB4-101A-B69C-00AA00341D07}']
function GetClassInfo(out pptti : ITypeInfo):HResult; StdCall;
end;
IProvideClassInfo2 = Interface (IProvideClassInfo)
['{A6BC3AC0-DBAA-11CE-9DE3-00AA004BB851}']
function GetGUID(dwguid:DWord;out pguid:TGUID):HResult; StdCall;
end;
{ ******************************************************************************************************************
stuff from objbase.h

51
packages/winunits-base/src/comobj.pp
View File

@ -175,6 +175,28 @@ unit comobj;
property ThreadingModel: TThreadingModel read FThreadingModel;
end;
{ TTypedComObject }
TTypedComObject = class(TComObject, IProvideClassInfo)
function GetClassInfo(out pptti : ITypeInfo):HResult; StdCall;
end;
TTypedComClass = class of TTypedComObject;
{ TTypedComObjectFactory }
TTypedComObjectFactory = class(TComObjectFactory)
private
FClassInfo: ITypeInfo;
public
constructor Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
function GetInterfaceTypeInfo(TypeFlags: Integer) : ITypeInfo;
procedure UpdateRegistry(Register: Boolean);override;
property ClassInfo : ITypeInfo read FClassInfo;
end;
function CreateClassID : ansistring;
function CreateComObject(const ClassID: TGUID) : IUnknown;
@ -1036,6 +1058,35 @@ implementation
FreeMem(Arguments);
end;
{ TTypedComObject }
function TTypedComObject.GetClassInfo(out pptti: ITypeInfo): HResult;stdcall;
begin
Result:=S_OK;
pptti:=TTypedComObjectFactory(factory).classinfo;
end;
{ TTypedComObjectFactory }
constructor TTypedComObjectFactory.Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
begin
RunError(217);
end;
function TTypedComObjectFactory.GetInterfaceTypeInfo(TypeFlags: Integer): ITypeInfo;
begin
RunError(217);
end;
procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
begin
RunError(217);
end;
const
Initialized : boolean = false;