home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / CORBAVCL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  2.8 KB  |  97 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1999 Inprise Corporation          }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit CorbaVCL;
  11.  
  12. {$T-,H+,X+}
  13.  
  14. interface
  15.  
  16. uses Classes, CorbaObj;
  17.  
  18. type
  19.   TCorbaVclComponentFactory = class(TCorbaFactory)
  20.   private
  21.     FComponentClass: TComponentClass;
  22.   protected
  23.     function CreateInterface(const InstanceName: string): IObject; override;
  24.   public
  25.     constructor Create(const InterfaceName, InstanceName, RepositoryId: string;
  26.       const ImplGUID: TGUID; AComponentClass: TComponentClass;
  27.       Instancing: TCorbaInstancing = iMultiInstance;
  28.       ThreadModel: TCorbaThreadModel = tmSingleThread);
  29.     property ComponentClass: TComponentClass read FComponentClass;
  30.   end;
  31.  
  32. implementation
  33.  
  34. type
  35.   TCorbaVclComponentAdapter = class(TCorbaImplementation, IVCLComObject)
  36.   private
  37.     FComponent: TComponent;
  38.   protected
  39.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  40.     procedure FreeOnRelease;
  41.   public
  42.     //constructor Create(AComponentClass: TComponentClass); reintroduce;
  43.     constructor CreateFromFactory(AFactory: TCorbaVclComponentFactory);
  44.     destructor Destroy; override;
  45.   end;
  46.  
  47. { TCorbaVclComponentAdapter }
  48.  
  49. constructor TCorbaVclComponentAdapter.CreateFromFactory(AFactory: TCorbaVclComponentFactory);
  50. begin
  51.   inherited Create(nil, AFactory);
  52.   FComponent := AFactory.ComponentClass.Create(nil);
  53.   FComponent.VCLComObject := Pointer(IVCLComObject(Self));
  54. end;
  55.  
  56. destructor TCorbaVclComponentAdapter.Destroy;
  57. begin
  58.   if FComponent <> nil then
  59.   begin
  60.     FComponent.VCLComObject := nil;
  61.     FComponent.Free;
  62.   end;
  63.   inherited Destroy;
  64. end;
  65.  
  66. procedure TCorbaVclComponentAdapter.FreeOnRelease;
  67. begin
  68.   // Always frees on release
  69. end;
  70.  
  71. function TCorbaVclComponentAdapter.ObjQueryInterface(const IID: TGUID;
  72.   out Obj): HResult;
  73. begin
  74.   Result := inherited ObjQueryInterface(IID, Obj);
  75.   if Result <> 0 then
  76.     if FComponent.GetInterface(IID, Obj) then Result := 0;
  77. end;
  78.  
  79. { TCorbaVclComponentFactory }
  80.  
  81. constructor TCorbaVclComponentFactory.Create(const InterfaceName,
  82.   InstanceName, RepositoryId: string; const ImplGUID: TGUID;
  83.   AComponentClass: TComponentClass; Instancing: TCorbaInstancing;
  84.   ThreadModel: TCorbaThreadModel);
  85. begin
  86.   inherited Create(InterfaceName, InstanceName, RepositoryID, ImplGUID,
  87.     Instancing, ThreadModel);
  88.   FComponentClass := AComponentClass;
  89. end;
  90.  
  91. function TCorbaVclComponentFactory.CreateInterface(const InstanceName: string): IObject;
  92. begin
  93.   Result := TCorbaVclComponentAdapter.CreateFromFactory(Self);
  94. end;
  95.  
  96. end.
  97.