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. |