Subversion Repositories decoder

Compare Revisions

Regard whitespace Rev 1 → Rev 2

/trunk/VCL_DRAGDROP/DragDropComObj.pas
0,0 → 1,344
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.