home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 2000 March / pcp161b.iso / full / delphi / RUNIMAGE / DELPHI30 / SOURCE / VCL / VCLCOM.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-08-03  |  4.0 KB  |  148 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1997 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit VCLCom;
  11.  
  12. interface
  13.  
  14. uses ActiveX, ComObj, Classes;
  15.  
  16. type
  17.  
  18. { Component object factory }
  19.  
  20.   TComponentFactory = class(TAutoObjectFactory)
  21.   protected
  22.     function CreateComObject(const Controller: IUnknown): TComObject; override;
  23.     procedure UpdateRegistry(Register: Boolean); override;
  24.   public
  25.     constructor Create(ComServer: TComServerObject;
  26.       ComponentClass: TComponentClass; const ClassID: TGUID;
  27.       Instancing: TClassInstancing);
  28.   end;
  29.  
  30. implementation
  31.  
  32. type
  33.  
  34. { VCL OLE Automation object }
  35.  
  36.   TVCLAutoObject = class(TAutoObject, IVCLComObject)
  37.   private
  38.     FComponent: TComponent;
  39.     FOwnsComponent: Boolean;
  40.   protected
  41.     procedure FreeOnRelease;
  42.     function Invoke(DispID: Integer; const IID: TGUID;
  43.       LocaleID: Integer; Flags: Word; var Params;
  44.       VarResult, ExcepInfo, ArgErr: Pointer): HResult; override;
  45.   public
  46.     constructor Create(Factory: TComObjectFactory; Component: TComponent);
  47.     destructor Destroy; override;
  48.     procedure Initialize; override;
  49.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override;
  50.   end;
  51.  
  52. { TVCLAutoObject }
  53.  
  54. constructor TVCLAutoObject.Create(Factory: TComObjectFactory;
  55.   Component: TComponent);
  56. begin
  57.   FComponent := Component;
  58.   CreateFromFactory(Factory, nil);
  59. end;
  60.  
  61. destructor TVCLAutoObject.Destroy;
  62. begin
  63.   if FComponent <> nil then
  64.   begin
  65.     FComponent.VCLComObject := nil;
  66.     if FOwnsComponent then FComponent.Free;
  67.   end;
  68.   inherited Destroy;
  69. end;
  70.  
  71. procedure TVCLAutoObject.FreeOnRelease;
  72. begin
  73.   FOwnsComponent := True;
  74. end;
  75.  
  76. procedure TVCLAutoObject.Initialize;
  77. begin
  78.   if FComponent = nil then
  79.   begin
  80.     FComponent := TComponentClass(Factory.ComClass).Create(nil);
  81.     FOwnsComponent := True;
  82.   end;
  83.   FComponent.VCLComObject := Pointer(IVCLComObject(Self));
  84. end;
  85.  
  86. function TVCLAutoObject.Invoke(DispID: Integer; const IID: TGUID;
  87.   LocaleID: Integer; Flags: Word; var Params;
  88.   VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  89. begin
  90.   Result := DispInvoke(Pointer(Integer(FComponent) +
  91.     TComponentFactory(Factory).DispIntfEntry^.IOffset),
  92.     TComponentFactory(Factory).DispTypeInfo, DispID, Flags,
  93.     TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  94. end;
  95.  
  96. function TVCLAutoObject.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
  97. begin
  98.   Result := inherited ObjQueryInterface(IID, Obj);
  99.   if Result <> 0 then
  100.     if FComponent.GetInterface(IID, Obj) then Result := 0;
  101. end;
  102.  
  103. { TComponentFactory }
  104.  
  105. constructor TComponentFactory.Create(ComServer: TComServerObject;
  106.   ComponentClass: TComponentClass; const ClassID: TGUID;
  107.   Instancing: TClassInstancing);
  108. begin
  109.   inherited Create(ComServer, TAutoClass(ComponentClass),
  110.     ClassID, Instancing);
  111. end;
  112.  
  113. type
  114.   TComponentProtectedAccess = class(TComponent);
  115.   TComponentProtectedAccessClass = class of TComponentProtectedAccess;
  116.  
  117. procedure TComponentFactory.UpdateRegistry(Register: Boolean);
  118. begin
  119.   if Register then inherited UpdateRegistry(Register);
  120.   TComponentProtectedAccessClass(ComClass).UpdateRegistry(Register, GUIDToString(ClassID), ProgID);
  121.   if not Register then inherited UpdateRegistry(Register);
  122. end;
  123.  
  124. function TComponentFactory.CreateComObject(const Controller: IUnknown): TComObject;
  125. begin
  126.   Result := TVCLAutoObject.CreateFromFactory(Self, Controller);
  127. end;
  128.  
  129. { Global routines }
  130.  
  131. procedure CreateVCLComObject(Component: TComponent);
  132. begin
  133.   TVCLAutoObject.Create(ComClassManager.GetFactoryFromClass(
  134.     Component.ClassType), Component);
  135. end;
  136.  
  137. initialization
  138. begin
  139.   CreateVCLComObjectProc := CreateVCLComObject;
  140. end;
  141.  
  142. finalization
  143. begin
  144.   CreateVCLComObjectProc := nil;
  145. end;
  146.  
  147. end.
  148.