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

* fixed compilation win32/win64 after (my) last commit.

Browse Source 
due to wince <-> win32/win64 headerwise. wince has some identifiers in Windows that win32/win64 has in activex
 * patches for comobj/comserv from 0014822 and 0014939	as well as one minor fix to activex.

git-svn-id: trunk@13991 -
This commit is contained in:
marco 2009-10-31 22:31:26 +00:00
parent 4d0272fd5c
commit de350d5c26
4 changed files with 492 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -2846,9 +2846,10 @@ TYPE
Function LocalInvoke ():HResult;StdCall;
{$endif}
{$ifndef Call_as}
Function GetDocumentation(memid: MEMBERID; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
//Function GetDocumentation(memid: MEMBERID; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
Function GetDocumentation(memid: MEMBERID; pBstrName: PWideString; pBstrDocString: PWideString; pdwHelpContext: PDWORD; pBstrHelpFile: PWideString):HResult;StdCall;
{$else}
Function GetDocumentation(memid: MEMBERID; refPtrFlags: DWORD; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
Function GetDocumentation(memid: MEMBERID; refPtrFlags: DWORD; OUT pBstrName: WideString; OUT pBstrDocString: WideString; OUT pdwHelpContext: DWORD; OUT pBstrHelpFile: WideString):HResult;StdCall;
{$endif}
{$ifndef Call_as}

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

@ -18,8 +18,8 @@ unit comobj;
interface
{$define DEBUG_COM}
{ $define DEBUG_COM}
{ $define DUMMY_REG}
uses
Windows,Types,Variants,Sysutils,ActiveX,classes;
@ -136,6 +136,8 @@ unit comobj;
TClassInstancing = (ciInternal, ciSingleInstance, ciMultiInstance);
TThreadingModel = (tmSingle, tmApartment, tmFree, tmBoth, tmNeutral);
{ TComObjectFactory }
TComObjectFactory = class(TObject, IUnknown, IClassFactory, IClassFactory2)
private
FRefCount : Integer;
@ -144,6 +146,7 @@ unit comobj;
FComClass: TClass;
FClassID: TGUID;
FClassName: string;
FClassVersion : String;
FDescription: string;
FErrorIID: TGUID;
FInstancing: TClassInstancing;
@ -171,12 +174,16 @@ unit comobj;
constructor Create(ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const Name, Description: string;
Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
constructor Create(ComServer: TComServerObject; ComClass: TComClass;
const ClassID: TGUID; const Name, Version, Description: string;
Instancing: TClassInstancing; ThreadingModel: TThreadingModel = tmSingle);
destructor Destroy; override;
function CreateComObject(const Controller: IUnknown): TComObject; virtual;
procedure RegisterClassObject;
procedure UpdateRegistry(Register: Boolean); virtual;
property ClassID: TGUID read FClassID;
property ClassName: string read FClassName;
property ClassVersion: string read FClassVersion;
property ComClass: TClass read FComClass;
property ComServer: TComServerObject read FComServer;
property Description: string read FDescription;
@ -210,6 +217,48 @@ unit comobj;
property ClassInfo : ITypeInfo read FClassInfo;
end;
{ TAutoObject }
TAutoObject = class(TTypedComObject, IDispatch)
protected
{ IDispatch }
function GetTypeInfoCount(out count : longint) : HResult;stdcall;
function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall;
function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
public
end;
TAutoClass = class of TAutoObject;
{ TAutoObjectFactory }
TAutoObjectFactory = class(TTypedComObjectFactory)
public
constructor Create(AComServer: TComServerObject; AutoClass: TAutoClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
end;
{ TAutoIntfObject }
//example of how to implement IDispatch: http://www.opensource.apple.com/source/vim/vim-34/vim/src/if_ole.cpp
TAutoIntfObject = class(TInterfacedObject, IDispatch, ISupportErrorInfo)
private
fTypeInfo: ITypeInfo;
fInterfacePointer: Pointer;
protected
{ IDispatch }
function GetTypeInfoCount(out count : longint) : HResult;stdcall;
function GetTypeInfo(Index,LocaleID : longint; out TypeInfo): HResult;stdcall;
function GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
function Invoke(DispID: LongInt;const iid : TGUID; LocaleID : longint; Flags: Word;var params; VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
{ ISupportErrorInfo }
function InterfaceSupportsErrorInfo(CONST riid: TIID):HResult;StdCall;
public
function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; override;
constructor Create(TypeLib: ITypeLib; const Guid: TGuid);
end;
function CreateClassID : ansistring;
@ -256,7 +305,7 @@ unit comobj;
implementation
uses
ComConst,Ole2, Registry;
ComConst, Ole2, Registry, RtlConsts;
var
Uninitializing : boolean;
@ -374,7 +423,6 @@ implementation
OleCheck(CoCreateInstance(id,nil,CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER,IDispatch,result));
end;
function GetActiveOleObject(const ClassName : string) : IDispatch;
{$ifndef wince}
var
@ -391,6 +439,79 @@ implementation
end;
{$endif wince}
procedure CreateRegKey(const Key, ValueName, Value: string);
{$ifndef DUMMY_REG}
var
Reg: TRegistry;
{$endif}
begin
{$ifdef DEBUG_COM}
WriteLn('CreateRegKey: ', Key, ': ', ValueName, ': ', Value );
{$endif}
{$ifndef DUMMY_REG}
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKey(Key, True) then
begin
try
Reg.WriteString(ValueName, Value);
finally
Reg.CloseKey;
end;
end
else
raise ERegistryException.CreateResFmt(@SRegCreateFailed, [Key]);
finally
Reg.Free;
end;
{$endif}
{$ifdef DEBUG_COM}
WriteLn('CreateRegKey exit: ', Key, ': ', ValueName, ': ', Value );
{$endif}
end;
procedure DeleteRegKey(const Key: string);
{$ifndef DUMMY_REG}
var
Reg: TRegistry;
{$endif}
begin
{$ifdef DEBUG_COM}
WriteLn('DeleteRegKey: ', Key);
{$endif}
{$ifndef DUMMY_REG}
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CLASSES_ROOT;
Reg.DeleteKey(Key);
finally
Reg.Free;
end;
{$endif}
end;
function GetRegStringValue(const Key, ValueName: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create();
try
Reg.RootKey := HKEY_CLASSES_ROOT;
if Reg.OpenKeyReadOnly(Key) then
begin
try
Result := Reg.ReadString(ValueName)
finally
Reg.CloseKey;
end;
end
else
Result := '';
finally
Reg.Free;
end;
end;
procedure OleError(Code: HResult);
begin
@ -685,7 +806,7 @@ implementation
function TComObjectFactory.GetProgID: string;
begin
RunError(217);
Result := FComServer.GetServerName + '.' + FClassName;
end;
@ -771,6 +892,13 @@ implementation
Description: string; Instancing: TClassInstancing;
ThreadingModel: TThreadingModel);
begin
Create(ComServer, ComClass, ClassID, Name, '', Description, Instancing, ThreadingModel);
end;
constructor TComObjectFactory.Create(ComServer: TComServerObject;
ComClass: TComClass; const ClassID: TGUID; const Name, Version, Description: string; Instancing: TClassInstancing;
ThreadingModel: TThreadingModel);
begin
{$ifdef DEBUG_COM}
WriteLn('TComObjectFactory.Create');
{$endif}
@ -779,6 +907,7 @@ implementation
FThreadingModel := ThreadingModel;
FDescription := Description;
FClassName := Name;
FClassVersion := Version;
FComServer := ComServer;
FComClass := ComClass;
FInstancing := Instancing;;
@ -805,6 +934,9 @@ implementation
procedure TComObjectFactory.RegisterClassObject;
begin
{$ifdef DEBUG_COM}
WriteLn('TComObjectFactory.RegisterClassObject');
{$endif}
RunError(217);
end;
@ -841,38 +973,69 @@ HKCR
procedure TComObjectFactory.UpdateRegistry(Register: Boolean);
var
reg: TRegistry;
begin
RunError(217);
classidguid: String;
function ThreadModelToString(model: TThreadingModel): String;
begin
case model of
tmSingle: Result := '';
tmApartment: Result := 'Apartment';
tmFree: Result := 'Free';
tmBoth: Result := 'Both';
tmNeutral: Result := 'Neutral';
end;
end;
begin
{$ifdef DEBUG_COM}
WriteLn('UpdateRegistry begin');
{$endif}
if Instancing = ciInternal then Exit;
//todo: finish this
if Register then
begin
reg := TRegistry.Create;
reg.RootKey := HKEY_CLASSES_ROOT;
reg.OpenKey(FClassName + '.1', True);
reg.WriteString('', Description);
reg.WriteString('CLSID', GUIDToString(ClassID));
reg.CloseKey;
classidguid := GUIDToString(ClassID);
CreateRegKey('CLSID\' + classidguid, '', Description);
if ClassVersion <> '' then
begin
CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID + '.' + ClassVersion);
CreateRegKey('CLSID\' + classidguid + '\VersionIndependentProgID', '', ProgID + '.' + ClassVersion);
end
else
CreateRegKey('CLSID\' + classidguid + '\ProgID', '', ProgID);
reg.OpenKey(FClassName, True);
reg.WriteString('', Description);
reg.WriteString('CLSID', GUIDToString(ClassID));
reg.WriteString('CurVer', FClassName + '.1');
reg.CloseKey;
CreateRegKey('CLSID\' + classidguid + '\InprocServer32', '', FComServer.ServerFileName);
reg.OpenKey('CLSID\' + GUIDToString(ClassID), True);
reg.WriteString('', Description);
reg.WriteString('ProgID', FClassName);
reg.WriteString('VersionIndependentProgID', FClassName);
reg.WriteString('InprocServer32', 'MODULENAME');
reg.CloseKey;
//tmSingle, tmApartment, tmFree, tmBoth, tmNeutral
CreateRegKey('CLSID\' + classidguid + '\InprocServer32', 'ThreadingModel', ThreadModelToString(ThreadingModel));
reg.Free;
CreateRegKey(ProgID, '', Description);
CreateRegKey(ProgID + '\CLSID', '', GUIDToString(ClassID));
if ClassVersion <> '' then
begin
CreateRegKey(ProgID + '\CurVer', '', ProgID + '.' + ClassVersion);
CreateRegKey(ProgID + '.' + ClassVersion, '', Description);
CreateRegKey(ProgID + '.' + ClassVersion + '\CLSID', '', GUIDToString(ClassID));
end;
end else
begin
classidguid := GUIDToString(ClassID);
DeleteRegKey('CLSID\' + classidguid + '\InprocServer32');
DeleteRegKey('CLSID\' + classidguid + '\VersionIndependentProgID');
DeleteRegKey('CLSID\' + classidguid + '\ProgID');
DeleteRegKey('CLSID\' + classidguid);
DeleteRegKey(ProgID + '\CLSID');
DeleteRegKey(ProgID);
if ClassVersion <> '' then
begin
DeleteRegKey(ProgID + '.' + ClassVersion + '\CLSID');
DeleteRegKey(ProgID + '.' + ClassVersion);
end;
end;
//This should be in typedcomobject
//reg.WriteString('TypeLib', FClassName);
{$ifdef DEBUG_COM}
WriteLn('UpdateRegistry end');
{$endif}
end;
@ -1259,13 +1422,28 @@ HKCR
constructor TTypedComObjectFactory.Create(AComServer: TComServerObject; TypedComClass: TTypedComClass; const AClassID: TGUID;
AInstancing: TClassInstancing; AThreadingModel: TThreadingModel = tmSingle);
var
TypedName, TypedDescription: WideString;
TypedName, TypedDescription, TypedVersion: WideString;
ppTypeAttr: lpTYPEATTR;
begin
//TDB get name and description from typelib (check if this is a valid guid)
OleCheck(AComServer.GetTypeLib.GetTypeInfoOfGuid(AClassID, FClassInfo));
//bug FPC 0010569 - http://msdn2.microsoft.com/en-us/library/ms221396(VS.85).aspx
OleCheck(FClassInfo.GetDocumentation(-1, TypedName, TypedDescription, PLongWord(nil)^, PWideString(nil)^));
inherited Create(AComServer, TypedComClass, AClassID, TypedName, TypedDescription, AInstancing, AThreadingModel);
OleCheck(FClassInfo.GetDocumentation(-1, @TypedName, @TypedDescription, nil, nil));
FClassInfo.GetTypeAttr(ppTypeAttr);
try
TypedVersion := '';
if (ppTypeAttr^.wMajorVerNum <> 0) or (ppTypeAttr^.wMinorVerNum <> 0) then
begin
TypedVersion := IntToStr(ppTypeAttr^.wMajorVerNum);
if ppTypeAttr^.wMinorVerNum <> 0 then
TypedVersion := TypedVersion + '.' + IntToStr(ppTypeAttr^.wMinorVerNum)
end;
finally
FClassInfo.ReleaseTypeAttr(ppTypeAttr);
end;
inherited Create(AComServer, TypedComClass, AClassID, TypedName, TypedVersion, TypedDescription, AInstancing, AThreadingModel);
end;
@ -1276,11 +1454,198 @@ HKCR
procedure TTypedComObjectFactory.UpdateRegistry(Register: Boolean);
var
ptla: PTLibAttr;
begin
inherited UpdateRegistry(Register);
// 'TypeLib' = s '%LIBID%' missing ??? or does TComServer register it ?
//un/register typed library
RunError(217);
if Instancing = ciInternal then
Exit;
if Register then
begin
inherited UpdateRegistry(Register);
//http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
//There seems to also be Version according to Process Monitor
//http://technet.microsoft.com/en-us/sysinternals/bb896645.aspx
if FComServer.TypeLib = nil then
raise Exception.Create('TypeLib is not set!');
OleCheck(FComServer.TypeLib.GetLibAttr(ptla));
try
CreateRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib', '', GUIDToString(ptla^.GUID));
finally
FComServer.TypeLib.ReleaseTLibAttr(ptla);
end;
end else
begin
DeleteRegKey('CLSID\' + GUIDToString(ClassID) + '\TypeLib');
inherited UpdateRegistry(Register);
end;
end;
{ TAutoIntfObject }
function TAutoIntfObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.GetTypeInfoCount');
{$endif}
count := 1;
Result := S_OK;
end;
function TAutoIntfObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
{$endif}
if Index <> 0 then
Result := DISP_E_BADINDEX
else
begin
ITypeInfo(TypeInfo) := fTypeInfo;
Result := S_OK;
end;
end;
function TAutoIntfObject.GetIDsOfNames(const iid: TGUID; names: Pointer;
NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
{$endif}
//return typeinfo->GetIDsOfNames(names, n, dispids);
Result := fTypeInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^);
end;
function TAutoIntfObject.Invoke(DispID: LongInt; const iid: TGUID;
LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
ArgErr: pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
//WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
{$endif}
if not IsEqualGUID(iid, GUID_NULL) then
Result := DISP_E_UNKNOWNINTERFACE
else
// Function Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall;
// Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
Result := fTypeInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
end;
function TAutoIntfObject.InterfaceSupportsErrorInfo(const riid: TIID): HResult;
StdCall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.InterfaceSupportsErrorInfo: ', GUIDToString(riid));
{$endif}
if assigned(GetInterfaceEntry(riid)) then
Result:=S_OK
else
Result:=S_FALSE;
end;
function TAutoIntfObject.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
var
//Message: string;
Handled: Integer;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.SafeCallException');
{$endif}
Handled:=0;
Result:=0;
//TODO: DO WE NEED THIS ?
//if assigned(ServerExceptionHandler) then
// begin
// if ExceptObject is Exception then
// Message:=Exception(ExceptObject).Message;
//
// ServerExceptionHandler.OnException(ClassName,ExceptObject.ClassName,
// Message,PtrInt(ExceptAddr),WideString(GUIDToString(FFactory.ErrorIID)),
// FFactory.ProgID,Handled,Result);
// end;
if Handled=0 then
Result:=HandleSafeCallException(ExceptObject,ExceptAddr,StringToGuid('{7C538328-8A75-4EC4-A02E-FB3B27FAA411}'),
'','');
end;
constructor TAutoIntfObject.Create(TypeLib: ITypeLib; const Guid: TGuid);
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.Create: ', GUIDToString(Guid));
{$endif}
OleCheck(TypeLib.GetTypeInfoOfGuid(Guid, fTypeInfo));
OleCheck(QueryInterface(Guid, fInterfacePointer));
end;
{ TAutoObject }
function TAutoObject.GetTypeInfoCount(out count: longint): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoObject.GetTypeInfoCount');
{$endif}
count := 1;
Result := S_OK;
end;
function TAutoObject.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.GetTypeInfo: ', Index);
{$endif}
if Index <> 0 then
Result := DISP_E_BADINDEX
else
begin
ITypeInfo(TypeInfo) := TAutoObjectFactory(Factory).ClassInfo;
Result := S_OK;
end;
end;
function TAutoObject.GetIDsOfNames(const iid: TGUID; names: Pointer; NameCount,
LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.GetIDsOfNames: ', GUIDToString(iid));
{$endif}
//return typeinfo->GetIDsOfNames(names, n, dispids);
Result := TAutoObjectFactory(Factory).ClassInfo.GetIDsOfNames(names, NameCount, lpDISPID(DispIDs)^);
end;
function TAutoObject.Invoke(DispID: LongInt; const iid: TGUID;
LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
ArgErr: pointer): HResult; stdcall;
var
fInterfacePointer: Pointer;
begin
{$ifdef DEBUG_COM}
WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', GUIDToString(iid));
//WriteLn('TAutoIntfObject.Invoke: ', DispID, ': ', Flags, ': ', TDispParams(params).cArgs, ': ', TDispParams(params).rgvarg^, ': ', GUIDToString(iid));
{$endif}
if not IsEqualGUID(iid, GUID_NULL) then
Result := DISP_E_UNKNOWNINTERFACE
else
begin
// Function Invoke(pvInstance: Pointer; memid: MEMBERID; wFlags: WORD; VAR pDispParams: DISPPARAMS; OUT pVarResult: VARIANT; OUT pExcepInfo: EXCEPINFO; OUT puArgErr: UINT):HResult;StdCall;
// Result := fTypeInfo.Invoke(IDispatch(Self), DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
OleCheck(QueryInterface(TAutoObjectFactory(Factory).ClassID, fInterfacePointer));
Result := TAutoObjectFactory(Factory).ClassInfo.Invoke(fInterfacePointer, DispID, Flags, TDispParams(params), PVariant(VarResult)^, PExcepInfo(ExcepInfo)^, PUINT(ArgErr)^);
end;
end;
{ TAutoObjectFactory }
constructor TAutoObjectFactory.Create(AComServer: TComServerObject;
AutoClass: TAutoClass; const AClassID: TGUID; AInstancing: TClassInstancing;
AThreadingModel: TThreadingModel);
begin
inherited Create(AComServer, AutoClass, AClassID, AInstancing, AThreadingModel);
end;
procedure TOleStream.Check(err:integer);

88
packages/winunits-base/src/comserv.pp
View File

@ -21,7 +21,7 @@ interface
uses
Classes, SysUtils, comobj, ActiveX;
{$define DEBUG_COM}
{ $define DEBUG_COM}
//according to doc
// * ComServer Variable
@ -44,6 +44,9 @@ type
private
fCountObject: Integer;
fCountFactory: Integer;
fTypeLib: ITypeLib;
fServerName,
fServerFileName: String;
protected
function CountObject(Created: Boolean): Integer; override;
function CountFactory(Created: Boolean): Integer; override;
@ -60,6 +63,7 @@ type
procedure UnregisterServerFactory(Factory: TComObjectFactory);
public
constructor Create;
destructor Destroy; override;
function CanUnloadNow: Boolean;
procedure RegisterServer;
procedure UnRegisterServer;
@ -90,6 +94,9 @@ function DllUnregisterServer: HResult; stdcall;
implementation
uses
Windows;
function DllCanUnloadNow: HResult; stdcall;
begin
{$ifdef DEBUG_COM}
@ -168,6 +175,43 @@ begin
end;
end;
function GetModuleFileName: String;
const
MAX_PATH_SIZE = 2048;
begin
SetLength(Result, MAX_PATH_SIZE);
SetLength(Result, Windows.GetModuleFileName(HInstance, @Result[1], MAX_PATH_SIZE));
end;
function GetModuleName: String;
begin
Result := ExtractFileName(GetModuleFileName);
Result := Copy(Result, 1,LastDelimiter('.', Result)-1);
end;
procedure RegisterTypeLib(TypeLib: ITypeLib; const ModuleName: string);
var
FullPath: WideString;
begin
FullPath := ModuleName;
//according to MSDN helpdir can be null
OleCheck(ActiveX.RegisterTypeLib(TypeLib, @FullPath[1], nil));
end;
procedure UnRegisterTypeLib(TypeLib: ITypeLib);
var
ptla: PTLibAttr;
begin
//http://www.experts-exchange.com/Programming/Misc/Q_20634807.html
OleCheck(TypeLib.GetLibAttr(ptla));
try
OleCheck(ActiveX.UnRegisterTypeLib(ptla^.guid, ptla^.wMajorVerNum, ptla^.wMinorVerNum, ptla^.lcid, ptla^.syskind));
finally
TypeLib.ReleaseTLibAttr(ptla);
end;
end;
{ TComServer }
function TComServer.CountObject(Created: Boolean): Integer;
@ -193,7 +237,7 @@ end;
function TComServer.GetServerFileName: string;
begin
RunError(217);
Result := fServerFileName;
end;
function TComServer.GetServerKey: string;
@ -203,7 +247,7 @@ end;
function TComServer.GetServerName: string;
begin
RunError(217);
Result := fServerName;
end;
function TComServer.GetStartSuspended: Boolean;
@ -213,7 +257,7 @@ end;
function TComServer.GetTypeLib: ITypeLib;
begin
RunError(217);
Result := fTypeLib;
end;
procedure TComServer.SetHelpFileName(const Value: string);
@ -228,13 +272,41 @@ end;
procedure TComServer.UnregisterServerFactory(Factory: TComObjectFactory);
begin
Factory.UpdateRegistry(false);
Factory.UpdateRegistry(False);
end;
constructor TComServer.Create;
var
name: WideString;
begin
inherited Create;
{$ifdef DEBUG_COM}
WriteLn('TComServer.Create');
{$endif}
fCountFactory := 0;
fCountObject := 0;
fServerFileName := GetModuleFileName();
name := fServerFileName;
if not(Succeeded(LoadTypeLib(@name[1], fTypeLib))) then
fTypeLib := nil;
if FTypeLib <> nil then
begin
fTypeLib.GetDocumentation(-1, @name, nil, nil, nil);
fServerName := name;
end
else
fServerName := GetModuleName;
end;
destructor TComServer.Destroy;
begin
inherited Destroy;
{$ifdef DEBUG_COM}
WriteLn('TComServer.Destroy');
{$endif}
end;
function TComServer.CanUnloadNow: Boolean;
@ -244,11 +316,17 @@ end;
procedure TComServer.RegisterServer;
begin
if fTypeLib <> nil then
RegisterTypeLib(fTypeLib, fServerFileName);
ComClassManager.ForEachFactory(self, @RegisterServerFactory);
end;
procedure TComServer.UnRegisterServer;
begin
if fTypeLib <> nil then
UnRegisterTypeLib(fTypeLib);
ComClassManager.ForEachFactory(self, @UnregisterServerFactory);
end;

7
rtl/objpas/types.pp
View File

@ -134,7 +134,9 @@ type
const
GUID_NULL: TGUID = '{00000000-0000-0000-0000-000000000000}';
{$ifndef Windows}
{$ifndef Wince}
// in Wince these are in unit windows. Under 32/64 in ActiveX.
// for now duplicate them. Not that bad for untyped constants.
STGTY_STORAGE = 1;
STGTY_STREAM = 2;
STGTY_LOCKBYTES = 3;
@ -197,7 +199,8 @@ const
STATFLAG_DEFAULT = 0;
STATFLAG_NONAME = 1;
STATFLAG_NOOPEN = 2;
{$endif}
{$ifndef Windows}
type
PCLSID = PGUID;
TCLSID = TGUID;