unit dsPrivilegedClassFactory;

interface
uses
 Windows, SysUtils, Classes, System.Win.ComObj, System.Win.ComConst;

type
 TdsPrivilegedClassFactory = class(TTypedComObjectFactory)
  protected
   FResourceId: String;
  public
   constructor Create(const aResourceId: String; aComServer: TComServerObject; aTypedComClass: TTypedComClass; const aClassID: TGUID; aInstancing: TClassInstancing; aThreadingModel: TThreadingModel = tmSingle);
   procedure UpdateRegistry(Register: Boolean); override;
 end;

implementation

{ TdsPrivilegedClassFactory }

procedure CreateRegKeyDW(const Key, ValueName: string; Value: DWord; RootKey: HKEY);
var
  Handle: HKey;
  Status, Disposition: Integer;
begin
  Status := RegCreateKeyEx(RootKey, PChar(Key), 0, '', REG_OPTION_NON_VOLATILE, KEY_READ or KEY_WRITE, nil, Handle, @Disposition);

  if Status = 0 then
  begin
   Status := RegSetValueEx(Handle, PChar(ValueName), 0, REG_DWORD, @Value, SizeOf(DWord));
   RegCloseKey(Handle);
  end;
  if Status <> 0 then raise EOleRegistrationError.CreateRes(@SCreateRegKeyError);
end;

constructor TdsPrivilegedClassFactory.Create(const aResourceId: String;
  aComServer: TComServerObject; aTypedComClass: TTypedComClass;
  const aClassID: TGUID; aInstancing: TClassInstancing;
  aThreadingModel: TThreadingModel);
begin
 inherited Create(aComServer, aTypedComClass, aClassID, aInstancing, aThreadingModel);
 FResourceId := aResourceId;
end;

procedure TdsPrivilegedClassFactory.UpdateRegistry(Register: Boolean);
var
 RegPrefix: string;
 RootKey: HKEY;
 ID,
 AID,
 ClassKey,
 FullFileName,
 FileName: string;

procedure Install;
begin
 ID := GUIDToString(Self.ClassID);
 AID:='AppID\' + ID;
 FullFileName := ComServer.ServerFileName;
 FileName := ExtractFileName(FullFileName);

 CreateRegKey(AID, '', Description);
 CreateRegKey(AID, 'DllSurrogate', '');
 CreateRegKey('AppID\' + FileName, 'AppID', ID);

 CreateRegKey(ClassKey, 'AppID', ID);
 CreateRegKey(ClassKey, 'LocalizedString', '@' + FullFileName + ',-' + fResourceId);
 CreateRegKeyDW(ClassKey + '\Elevation', 'Enabled', 1, RootKey);
end;

procedure Uninstall;
begin
 ID := GUIDToString(Self.ClassID);
 AID:='AppID\' + ID;
 FullFileName := ComServer.ServerFileName;
 FileName := ExtractFileName(FullFileName);

 DeleteRegKey(ClassKey + '\Elevation');
 DeleteRegKey('AppID\' + ID);
 DeleteRegKey('AppID\' + FileName);
end;
begin
 ComServer.GetRegRootAndPrefix(RootKey, RegPrefix);

 ClassKey := RegPrefix + 'CLSID\' + GUIDToString(ClassID);

 if Register then
  begin
   inherited UpdateRegistry(Register);
   Install;
  end
 else
  begin
   Uninstall;
   inherited UpdateRegistry(Register);
  end;
end;

end.