RealICQClient/Includes/DRAGDROP/Components/DragDropComObj.pas

unit DragDropComObj;

// -----------------------------------------------------------------------------
// Project:         Drag and Drop Component Suite.
// Module:          DragDropComObj
// Description:     Implements misc COM support classes.
// Version:         4.0
// Date:            18-MAY-2001
// Target:          Win32, Delphi 5-6
// Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
// Copyright        © 1997-2001 Angus Johnson & Anders Melander
// -----------------------------------------------------------------------------
interface

uses
  ComObj,
  Classes,
  ActiveX;

{$include DragDrop.inc}

////////////////////////////////////////////////////////////////////////////////
//
//		TVCLComObject
//
////////////////////////////////////////////////////////////////////////////////
// Based on TVCLAutoObject.
////////////////////////////////////////////////////////////////////////////////
type
  TVCLComObject = class(TComObject, IVCLComObject, IUnknown)
  private
    FComponent: TComponent;
    FOwnsComponent: Boolean;
  protected
    // IVCLComObject implementation
    procedure FreeOnRelease;
    function Invoke(DispID: Integer; const IID: TGUID;
      LocaleID: Integer; Flags: Word; var Params;
      VarResult, ExcepInfo, ArgErr: Pointer): HResult;  virtual; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
    function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  public
    // TODO : For now, please ignore linker warning about TVCLComObject.Create
    constructor Create(Factory: TComObjectFactory; Component: TComponent);
    destructor Destroy; override;
    procedure Initialize; override;
    function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//		TVCLComObjectFactory
//
////////////////////////////////////////////////////////////////////////////////
// Class factory for component based COM classes.
// Does not require a type library.
// Based on TComponentFactory and TComObjectFactory.
////////////////////////////////////////////////////////////////////////////////
type
  TVCLComObjectFactory = class(TComObjectFactory, IClassFactory)
  private
  protected
    function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
      out Obj): HResult; stdcall;
  public
    constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass;
      const ClassID: TGUID; const ClassName, Description: string;
      Instancing: TClassInstancing);
    function CreateComObject(const Controller: IUnknown): TComObject; override;
    procedure UpdateRegistry(Register: Boolean); override;
  end;

////////////////////////////////////////////////////////////////////////////////
//
//		TShellExtFactory
//
////////////////////////////////////////////////////////////////////////////////
// Class factory for component based COM classes.
// Specialized for Shell Extensions.
////////////////////////////////////////////////////////////////////////////////
  TShellExtFactory = class(TVCLComObjectFactory)
  private
    FFileExtension: string;
    FFileClass: string;
  protected
  public
    constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass;
      const ClassID: TGUID; const ClassName, Description, AFileClass,
      AFileExtension: string; Instancing: TClassInstancing);
    procedure UpdateRegistry(Register: Boolean); override;
    property FileClass: string read FFileClass write FFileClass;
    property FileExtension: string read FFileExtension write FFileExtension;
  end;



////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
//
//			IMPLEMENTATION
//
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
implementation

uses
  Windows;

////////////////////////////////////////////////////////////////////////////////
//
//		TVCLComObject
//
////////////////////////////////////////////////////////////////////////////////
constructor TVCLComObject.Create(Factory: TComObjectFactory;
  Component: TComponent);
begin
  FComponent := Component;
  CreateFromFactory(Factory, nil);
end;

destructor TVCLComObject.Destroy;
begin
  if FComponent <> nil then
  begin
    FComponent.VCLComObject := nil;
    if FOwnsComponent then
      FComponent.Free;
  end;
  inherited Destroy;
end;

procedure TVCLComObject.FreeOnRelease;
begin
  FOwnsComponent := True;
end;

function TVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TVCLComObject.GetTypeInfo(Index, LocaleID: Integer;
  out TypeInfo): HResult;
begin
  Pointer(TypeInfo) := nil;
  Result := E_NOTIMPL;
end;

function TVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
begin
  Count := 0;
  Result := E_NOTIMPL;
end;

procedure TVCLComObject.Initialize;
begin
  inherited Initialize;
  if FComponent = nil then
  begin
    FComponent := TComponentClass(Factory.ComClass).Create(nil);
    FOwnsComponent := True;
  end;
  FComponent.VCLComObject := Pointer(IVCLComObject(Self));
end;

function TVCLComObject.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  ArgErr: Pointer): HResult;
begin
  Result := E_NOTIMPL;
end;

function TVCLComObject.ObjQueryInterface(const IID: TGUID;
  out Obj): HResult;
begin
  Result := inherited ObjQueryInterface(IID, Obj);
  if (Result <> 0) and (FComponent <> nil) then
    if FComponent.GetInterface(IID, Obj) then
      Result := 0;
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TApartmentThread
//
////////////////////////////////////////////////////////////////////////////////
// Copied from VCLCom unit.
////////////////////////////////////////////////////////////////////////////////
type
  TApartmentThread = class(TThread)
  private
    FFactory: IClassFactory2;
    FUnkOuter: IUnknown;
    FIID: TGuid;
    FSemaphore: THandle;
    FStream: Pointer;
    FCreateResult: HResult;
  protected
    procedure Execute; override;
  public
    constructor Create(Factory: IClassFactory2; UnkOuter: IUnknown; IID: TGuid);
    destructor Destroy; override;
    property Semaphore: THandle read FSemaphore;
    property CreateResult: HResult read FCreateResult;
    property ObjStream: Pointer read FStream;
  end;

constructor TApartmentThread.Create(Factory: IClassFactory2;
  UnkOuter: IUnknown; IID: TGuid);
begin
  FFactory := Factory;
  FUnkOuter := UnkOuter;
  FIID := IID;
  FSemaphore := CreateSemaphore(nil, 0, 1, nil);
  FreeOnTerminate := True;
  inherited Create(False);
end;

destructor TApartmentThread.Destroy;
begin
  CloseHandle(FSemaphore);
  inherited Destroy;
end;

procedure TApartmentThread.Execute;
var
  msg: TMsg;
  Unk: IUnknown;
begin
  try
    CoInitialize(nil);
    try
      FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
      FUnkOuter := nil;
      FFactory := nil;
      if FCreateResult = S_OK then
        CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
      ReleaseSemaphore(FSemaphore, 1, nil);
      if FCreateResult = S_OK then
        while GetMessage(msg, 0, 0, 0) do
        begin
          DispatchMessage(msg);
          Unk._AddRef;
          if Unk._Release = 1 then break;
        end;
    finally
      Unk := nil;
      CoUninitialize;
    end;
  except
    { No exceptions should go unhandled }
  end;
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TVCLComObjectFactory
//
////////////////////////////////////////////////////////////////////////////////
constructor TVCLComObjectFactory.Create(ComServer: TComServerObject;
  ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName,
  Description: string; Instancing: TClassInstancing);
begin
  inherited Create(ComServer, TComClass(ComponentClass), ClassID, ClassName,
    Description, Instancing, tmApartment);
end;

function TVCLComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
begin
  Result := TVCLComObject.CreateFromFactory(Self, Controller);
end;

function TVCLComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
  const IID: TGUID; out Obj): HResult;
begin
  if not IsLibrary then
  begin
    LockServer(True);
    try
      with TApartmentThread.Create(Self, UnkOuter, IID) do
      begin
        if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
        begin
          Result := CreateResult;
          if Result <> S_OK then Exit;
          Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
        end else
          Result := E_FAIL
      end;
    finally
      LockServer(False);
    end;
  end else
    Result := inherited CreateInstance(UnkOuter, IID, Obj);
end;

type
  TComponentProtectedAccess = class(TComponent);
  TComponentProtectedAccessClass = class of TComponentProtectedAccess;

procedure TVCLComObjectFactory.UpdateRegistry(Register: Boolean);
begin
  if Register then
    inherited UpdateRegistry(Register);
  TComponentProtectedAccessClass(ComClass).UpdateRegistry(Register,
    GUIDToString(ClassID), ProgID);
  if not Register then
    inherited UpdateRegistry(Register);
end;

////////////////////////////////////////////////////////////////////////////////
//
//		TShellExtFactory
//
////////////////////////////////////////////////////////////////////////////////
constructor TShellExtFactory.Create(ComServer: TComServerObject;
  ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName,
  Description, AFileClass, AFileExtension: string; Instancing: TClassInstancing);
begin
  inherited Create(ComServer, ComponentClass, ClassID, ClassName,
    Description, Instancing);
  FFileClass := AFileClass;
  FFileExtension := AFileExtension;
end;

procedure TShellExtFactory.UpdateRegistry(Register: Boolean);
begin
  if Register then
  begin
    inherited UpdateRegistry(Register);
    if (FileExtension <> '') then
      CreateRegKey(FileExtension, '', FileClass);
  end else
  begin
    if (FileExtension <> '') then
      RegDeleteKey(HKEY_CLASSES_ROOT, PChar(FileExtension));
    inherited UpdateRegistry(Register);
  end;
end;

end.