Subversion Repositories decoder

Rev

Blame | Last modification | View Log | RSS feed

  1. unit DragDropComObj;
  2.  
  3. // -----------------------------------------------------------------------------
  4. // Project:         Drag and Drop Component Suite.
  5. // Module:          DragDropComObj
  6. // Description:     Implements misc COM support classes.
  7. // Version:         4.0
  8. // Date:            18-MAY-2001
  9. // Target:          Win32, Delphi 5-6
  10. // Authors:         Anders Melander, anders@melander.dk, http://www.melander.dk
  11. // Copyright        © 1997-2001 Angus Johnson & Anders Melander
  12. // -----------------------------------------------------------------------------
  13. interface
  14.  
  15. uses
  16.   ComObj,
  17.   Classes,
  18.   ActiveX;
  19.  
  20. {$include DragDrop.inc}
  21.  
  22. ////////////////////////////////////////////////////////////////////////////////
  23. //
  24. //              TVCLComObject
  25. //
  26. ////////////////////////////////////////////////////////////////////////////////
  27. // Based on TVCLAutoObject.
  28. ////////////////////////////////////////////////////////////////////////////////
  29. type
  30.   TVCLComObject = class(TComObject, IVCLComObject, IUnknown)
  31.   private
  32.     FComponent: TComponent;
  33.     FOwnsComponent: Boolean;
  34.   protected
  35.     // IVCLComObject implementation
  36.     procedure FreeOnRelease;
  37.     function Invoke(DispID: Integer; const IID: TGUID;
  38.       LocaleID: Integer; Flags: Word; var Params;
  39.       VarResult, ExcepInfo, ArgErr: Pointer): HResult;  virtual; stdcall;
  40.     function GetIDsOfNames(const IID: TGUID; Names: Pointer;
  41.       NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; virtual; stdcall;
  42.     function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; virtual; stdcall;
  43.     function GetTypeInfoCount(out Count: Integer): HResult; virtual; stdcall;
  44.   public
  45.     // TODO : For now, please ignore linker warning about TVCLComObject.Create
  46.     constructor Create(Factory: TComObjectFactory; Component: TComponent);
  47.     destructor Destroy; override;
  48.     procedure Initialize; override;
  49.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  50.   end;
  51.  
  52. ////////////////////////////////////////////////////////////////////////////////
  53. //
  54. //              TVCLComObjectFactory
  55. //
  56. ////////////////////////////////////////////////////////////////////////////////
  57. // Class factory for component based COM classes.
  58. // Does not require a type library.
  59. // Based on TComponentFactory and TComObjectFactory.
  60. ////////////////////////////////////////////////////////////////////////////////
  61. type
  62.   TVCLComObjectFactory = class(TComObjectFactory, IClassFactory)
  63.   private
  64.   protected
  65.     function CreateInstance(const UnkOuter: IUnknown; const IID: TGUID;
  66.       out Obj): HResult; stdcall;
  67.   public
  68.     constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass;
  69.       const ClassID: TGUID; const ClassName, Description: string;
  70.       Instancing: TClassInstancing);
  71.     function CreateComObject(const Controller: IUnknown): TComObject; override;
  72.     procedure UpdateRegistry(Register: Boolean); override;
  73.   end;
  74.  
  75. ////////////////////////////////////////////////////////////////////////////////
  76. //
  77. //              TShellExtFactory
  78. //
  79. ////////////////////////////////////////////////////////////////////////////////
  80. // Class factory for component based COM classes.
  81. // Specialized for Shell Extensions.
  82. ////////////////////////////////////////////////////////////////////////////////
  83.   TShellExtFactory = class(TVCLComObjectFactory)
  84.   private
  85.     FFileExtension: string;
  86.     FFileClass: string;
  87.   protected
  88.   public
  89.     constructor Create(ComServer: TComServerObject; ComponentClass: TComponentClass;
  90.       const ClassID: TGUID; const ClassName, Description, AFileClass,
  91.       AFileExtension: string; Instancing: TClassInstancing);
  92.     procedure UpdateRegistry(Register: Boolean); override;
  93.     property FileClass: string read FFileClass write FFileClass;
  94.     property FileExtension: string read FFileExtension write FFileExtension;
  95.   end;
  96.  
  97.  
  98.  
  99. ////////////////////////////////////////////////////////////////////////////////
  100. ////////////////////////////////////////////////////////////////////////////////
  101. //
  102. //                      IMPLEMENTATION
  103. //
  104. ////////////////////////////////////////////////////////////////////////////////
  105. ////////////////////////////////////////////////////////////////////////////////
  106. implementation
  107.  
  108. uses
  109.   Windows;
  110.  
  111. ////////////////////////////////////////////////////////////////////////////////
  112. //
  113. //              TVCLComObject
  114. //
  115. ////////////////////////////////////////////////////////////////////////////////
  116. constructor TVCLComObject.Create(Factory: TComObjectFactory;
  117.   Component: TComponent);
  118. begin
  119.   FComponent := Component;
  120.   CreateFromFactory(Factory, nil);
  121. end;
  122.  
  123. destructor TVCLComObject.Destroy;
  124. begin
  125.   if FComponent <> nil then
  126.   begin
  127.     FComponent.VCLComObject := nil;
  128.     if FOwnsComponent then
  129.       FComponent.Free;
  130.   end;
  131.   inherited Destroy;
  132. end;
  133.  
  134. procedure TVCLComObject.FreeOnRelease;
  135. begin
  136.   FOwnsComponent := True;
  137. end;
  138.  
  139. function TVCLComObject.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  140.   NameCount, LocaleID: Integer; DispIDs: Pointer): HResult;
  141. begin
  142.   Result := E_NOTIMPL;
  143. end;
  144.  
  145. function TVCLComObject.GetTypeInfo(Index, LocaleID: Integer;
  146.   out TypeInfo): HResult;
  147. begin
  148.   Pointer(TypeInfo) := nil;
  149.   Result := E_NOTIMPL;
  150. end;
  151.  
  152. function TVCLComObject.GetTypeInfoCount(out Count: Integer): HResult;
  153. begin
  154.   Count := 0;
  155.   Result := E_NOTIMPL;
  156. end;
  157.  
  158. procedure TVCLComObject.Initialize;
  159. begin
  160.   inherited Initialize;
  161.   if FComponent = nil then
  162.   begin
  163.     FComponent := TComponentClass(Factory.ComClass).Create(nil);
  164.     FOwnsComponent := True;
  165.   end;
  166.   FComponent.VCLComObject := Pointer(IVCLComObject(Self));
  167. end;
  168.  
  169. function TVCLComObject.Invoke(DispID: Integer; const IID: TGUID;
  170.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  171.   ArgErr: Pointer): HResult;
  172. begin
  173.   Result := E_NOTIMPL;
  174. end;
  175.  
  176. function TVCLComObject.ObjQueryInterface(const IID: TGUID;
  177.   out Obj): HResult;
  178. begin
  179.   Result := inherited ObjQueryInterface(IID, Obj);
  180.   if (Result <> 0) and (FComponent <> nil) then
  181.     if FComponent.GetInterface(IID, Obj) then
  182.       Result := 0;
  183. end;
  184.  
  185. ////////////////////////////////////////////////////////////////////////////////
  186. //
  187. //              TApartmentThread
  188. //
  189. ////////////////////////////////////////////////////////////////////////////////
  190. // Copied from VCLCom unit.
  191. ////////////////////////////////////////////////////////////////////////////////
  192. type
  193.   TApartmentThread = class(TThread)
  194.   private
  195.     FFactory: IClassFactory2;
  196.     FUnkOuter: IUnknown;
  197.     FIID: TGuid;
  198.     FSemaphore: THandle;
  199.     FStream: Pointer;
  200.     FCreateResult: HResult;
  201.   protected
  202.     procedure Execute; override;
  203.   public
  204.     constructor Create(Factory: IClassFactory2; UnkOuter: IUnknown; IID: TGuid);
  205.     destructor Destroy; override;
  206.     property Semaphore: THandle read FSemaphore;
  207.     property CreateResult: HResult read FCreateResult;
  208.     property ObjStream: Pointer read FStream;
  209.   end;
  210.  
  211. constructor TApartmentThread.Create(Factory: IClassFactory2;
  212.   UnkOuter: IUnknown; IID: TGuid);
  213. begin
  214.   FFactory := Factory;
  215.   FUnkOuter := UnkOuter;
  216.   FIID := IID;
  217.   FSemaphore := CreateSemaphore(nil, 0, 1, nil);
  218.   FreeOnTerminate := True;
  219.   inherited Create(False);
  220. end;
  221.  
  222. destructor TApartmentThread.Destroy;
  223. begin
  224.   CloseHandle(FSemaphore);
  225.   inherited Destroy;
  226. end;
  227.  
  228. procedure TApartmentThread.Execute;
  229. var
  230.   msg: TMsg;
  231.   Unk: IUnknown;
  232. begin
  233.   try
  234.     CoInitialize(nil);
  235.     try
  236.       FCreateResult := FFactory.CreateInstanceLic(FUnkOuter, nil, FIID, '', Unk);
  237.       FUnkOuter := nil;
  238.       FFactory := nil;
  239.       if FCreateResult = S_OK then
  240.         CoMarshalInterThreadInterfaceInStream(FIID, Unk, IStream(FStream));
  241.       ReleaseSemaphore(FSemaphore, 1, nil);
  242.       if FCreateResult = S_OK then
  243.         while GetMessage(msg, 0, 0, 0) do
  244.         begin
  245.           DispatchMessage(msg);
  246.           Unk._AddRef;
  247.           if Unk._Release = 1 then break;
  248.         end;
  249.     finally
  250.       Unk := nil;
  251.       CoUninitialize;
  252.     end;
  253.   except
  254.     { No exceptions should go unhandled }
  255.   end;
  256. end;
  257.  
  258. ////////////////////////////////////////////////////////////////////////////////
  259. //
  260. //              TVCLComObjectFactory
  261. //
  262. ////////////////////////////////////////////////////////////////////////////////
  263. constructor TVCLComObjectFactory.Create(ComServer: TComServerObject;
  264.   ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName,
  265.   Description: string; Instancing: TClassInstancing);
  266. begin
  267.   inherited Create(ComServer, TComClass(ComponentClass), ClassID, ClassName,
  268.     Description, Instancing, tmApartment);
  269. end;
  270.  
  271. function TVCLComObjectFactory.CreateComObject(const Controller: IUnknown): TComObject;
  272. begin
  273.   Result := TVCLComObject.CreateFromFactory(Self, Controller);
  274. end;
  275.  
  276. function TVCLComObjectFactory.CreateInstance(const UnkOuter: IUnknown;
  277.   const IID: TGUID; out Obj): HResult;
  278. begin
  279.   if not IsLibrary then
  280.   begin
  281.     LockServer(True);
  282.     try
  283.       with TApartmentThread.Create(Self, UnkOuter, IID) do
  284.       begin
  285.         if WaitForSingleObject(Semaphore, INFINITE) = WAIT_OBJECT_0 then
  286.         begin
  287.           Result := CreateResult;
  288.           if Result <> S_OK then Exit;
  289.           Result := CoGetInterfaceAndReleaseStream(IStream(ObjStream), IID, Obj);
  290.         end else
  291.           Result := E_FAIL
  292.       end;
  293.     finally
  294.       LockServer(False);
  295.     end;
  296.   end else
  297.     Result := inherited CreateInstance(UnkOuter, IID, Obj);
  298. end;
  299.  
  300. type
  301.   TComponentProtectedAccess = class(TComponent);
  302.   TComponentProtectedAccessClass = class of TComponentProtectedAccess;
  303.  
  304. procedure TVCLComObjectFactory.UpdateRegistry(Register: Boolean);
  305. begin
  306.   if Register then
  307.     inherited UpdateRegistry(Register);
  308.   TComponentProtectedAccessClass(ComClass).UpdateRegistry(Register,
  309.     GUIDToString(ClassID), ProgID);
  310.   if not Register then
  311.     inherited UpdateRegistry(Register);
  312. end;
  313.  
  314. ////////////////////////////////////////////////////////////////////////////////
  315. //
  316. //              TShellExtFactory
  317. //
  318. ////////////////////////////////////////////////////////////////////////////////
  319. constructor TShellExtFactory.Create(ComServer: TComServerObject;
  320.   ComponentClass: TComponentClass; const ClassID: TGUID; const ClassName,
  321.   Description, AFileClass, AFileExtension: string; Instancing: TClassInstancing);
  322. begin
  323.   inherited Create(ComServer, ComponentClass, ClassID, ClassName,
  324.     Description, Instancing);
  325.   FFileClass := AFileClass;
  326.   FFileExtension := AFileExtension;
  327. end;
  328.  
  329. procedure TShellExtFactory.UpdateRegistry(Register: Boolean);
  330. begin
  331.   if Register then
  332.   begin
  333.     inherited UpdateRegistry(Register);
  334.     if (FileExtension <> '') then
  335.       CreateRegKey(FileExtension, '', FileClass);
  336.   end else
  337.   begin
  338.     if (FileExtension <> '') then
  339.       RegDeleteKey(HKEY_CLASSES_ROOT, PChar(FileExtension));
  340.     inherited UpdateRegistry(Register);
  341.   end;
  342. end;
  343.  
  344. end.
  345.