home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / AXCTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  118.2 KB  |  4,166 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {       ActiveX Controls Unit                           }
  6. {                                                       }
  7. {       Copyright (c) 1995,99 Inprise Corporation       }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit AxCtrls;
  12.  
  13. {$T-,H+,X+}
  14.  
  15. interface
  16.  
  17. (*$HPPEMIT '' *)
  18. (*$HPPEMIT '#include <objsafe.h>' *)
  19. (*$HPPEMIT '#include <ocidl.h>' *)
  20. (*$HPPEMIT '' *)
  21.  
  22. uses
  23.   Windows, Messages, ActiveX, SysUtils, ComObj, Classes, Graphics,
  24.   Controls, Forms, ExtCtrls, StdVcl;
  25.  
  26. const
  27.   { Delphi property page CLSIDs }
  28.   Class_DColorPropPage: TGUID = '{5CFF5D59-5946-11D0-BDEF-00A024D1875C}';
  29.   Class_DFontPropPage: TGUID = '{5CFF5D5B-5946-11D0-BDEF-00A024D1875C}';
  30.   Class_DPicturePropPage: TGUID = '{5CFF5D5A-5946-11D0-BDEF-00A024D1875C}';
  31.   Class_DStringPropPage: TGUID = '{F42D677E-754B-11D0-BDFB-00A024D1875C}';
  32.  
  33. type
  34.   TOleStream = class(TStream)
  35.   private
  36.     FStream: IStream;
  37.   protected
  38.     function GetIStream: IStream;
  39.   public
  40.     constructor Create(const Stream: IStream);
  41.     function Read(var Buffer; Count: Longint): Longint; override;
  42.     function Write(const Buffer; Count: Longint): Longint; override;
  43.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  44.   end;
  45.  
  46.   TConnectionPoints = class;
  47.  
  48.   TConnectionKind = (ckSingle, ckMulti);
  49.   {$EXTERNALSYM TConnectionKind}
  50.  
  51.   TConnectionPoint = class(TContainedObject, IConnectionPoint)
  52.   private
  53.     FContainer: TConnectionPoints;
  54.     FIID: TGUID;
  55.     FSinkList: TList;
  56.     FOnConnect: TConnectEvent;
  57.     FKind: TConnectionKind;
  58.     function AddSink(const Sink: IUnknown): Integer;
  59.     procedure RemoveSink(Cookie: Longint);
  60.   protected
  61.     { IConnectionPoint }
  62.     function GetConnectionInterface(out iid: TIID): HResult; stdcall;
  63.     function GetConnectionPointContainer(
  64.       out cpc: IConnectionPointContainer): HResult; stdcall;
  65.     function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult; stdcall;
  66.     function Unadvise(dwCookie: Longint): HResult; stdcall;
  67.     function EnumConnections(out enumconn: IEnumConnections): HResult; stdcall;
  68.   public
  69.     constructor Create(Container: TConnectionPoints;
  70.       const IID: TGUID; Kind: TConnectionKind; OnConnect: TConnectEvent);
  71.     property SinkList : TList read FSinkList;
  72.     destructor Destroy; override;
  73.   end;
  74.   {$EXTERNALSYM TConnectionPoint}
  75.  
  76.   TConnectionPoints = class{IConnectionPointContainer}
  77.   private
  78.     FController: Pointer;  // weak ref to controller - don't keep it alive
  79.     FConnectionPoints: TList;
  80.     function GetController: IUnknown;
  81.   protected
  82.     { IConnectionPointContainer }
  83.     function EnumConnectionPoints(
  84.       out enumconn: IEnumConnectionPoints): HResult; stdcall;
  85.     function FindConnectionPoint(const iid: TIID;
  86.       out cp: IConnectionPoint): HResult; stdcall;
  87.   public
  88.     constructor Create(const AController: IUnknown);
  89.     destructor Destroy; override;
  90.     function CreateConnectionPoint(const IID: TGUID; Kind: TConnectionKind;
  91.       OnConnect: TConnectEvent): TConnectionPoint;
  92.     property Controller: IUnknown read GetController;
  93.   end;
  94.   {$EXTERNALSYM TConnectionPoints}
  95.  
  96.   TDefinePropertyPage = procedure(const GUID: TGUID) of object;
  97.  
  98.   TActiveXControlFactory = class;
  99.   {$EXTERNALSYM TActiveXControlFactory}
  100.  
  101.   IAmbientDispatch = dispinterface
  102.     ['{00020400-0000-0000-C000-000000000046}']
  103.     property BackColor: Integer dispid DISPID_AMBIENT_BACKCOLOR;
  104.     property DisplayName: WideString dispid DISPID_AMBIENT_DISPLAYNAME;
  105.     property Font: IFontDisp dispid DISPID_AMBIENT_FONT;
  106.     property ForeColor: Integer dispid DISPID_AMBIENT_FORECOLOR;
  107.     property LocaleID: Integer dispid DISPID_AMBIENT_LOCALEID;
  108.     property MessageReflect: WordBool dispid DISPID_AMBIENT_MESSAGEREFLECT;
  109.     property ScaleUnits: WideString dispid DISPID_AMBIENT_SCALEUNITS;
  110.     property TextAlign: Smallint dispid DISPID_AMBIENT_TEXTALIGN;
  111.     property UserMode: WordBool dispid DISPID_AMBIENT_USERMODE;
  112.     property UIDead: WordBool dispid DISPID_AMBIENT_UIDEAD;
  113.     property ShowGrabHandles: WordBool dispid DISPID_AMBIENT_SHOWGRABHANDLES;
  114.     property ShowHatching: WordBool dispid DISPID_AMBIENT_SHOWHATCHING;
  115.     property DisplayAsDefault: WordBool dispid DISPID_AMBIENT_DISPLAYASDEFAULT;
  116.     property SupportsMnemonics: WordBool dispid DISPID_AMBIENT_SUPPORTSMNEMONICS;
  117.     property AutoClip: WordBool dispid DISPID_AMBIENT_AUTOCLIP;
  118.   end;
  119.  
  120.   TActiveXControl = class(TAutoObject,
  121.     IConnectionPointContainer,
  122.     IDataObject,
  123.     IObjectSafety,
  124.     IOleControl,
  125.     IOleInPlaceActiveObject,
  126.     IOleInPlaceObject,
  127.     IOleObject,
  128.     IPerPropertyBrowsing,
  129.     IPersistPropertyBag,
  130.     IPersistStorage,
  131.     IPersistStreamInit,
  132.     IQuickActivate,
  133.     ISimpleFrameSite,
  134.     ISpecifyPropertyPages,
  135.     IViewObject,
  136.     IViewObject2)
  137.  
  138.   private
  139.     FControlFactory: TActiveXControlFactory;
  140.     FConnectionPoints: TConnectionPoints;
  141.     FPropertySinks: TConnectionPoint;
  142.     FObjectSafetyFlags: DWORD;
  143.     FOleClientSite: IOleClientSite;
  144.     FOleControlSite: IOleControlSite;
  145.     FSimpleFrameSite: ISimpleFrameSite;
  146.     FAmbientDispatch: IAmbientDispatch;
  147.     FOleInPlaceSite: IOleInPlaceSite;
  148.     FOleInPlaceFrame: IOleInPlaceFrame;
  149.     FOleInPlaceUIWindow: IOleInPlaceUIWindow;
  150.     FOleAdviseHolder: IOleAdviseHolder;
  151.     FDataAdviseHolder: IDataAdviseHolder;
  152.     FAdviseSink: IAdviseSink;
  153.     FAdviseFlags: Integer;
  154.     FControl: TWinControl;
  155.     FControlWndProc: TWndMethod;
  156.     FWinControl: TWinControl;
  157.     FIsDirty: Boolean;
  158.     FInPlaceActive: Boolean;
  159.     FUIActive: Boolean;
  160.     FEventsFrozen: Boolean;
  161.     function CreateAdviseHolder: HResult;
  162.     function GetPropertyID(const PropertyName: WideString): Integer;
  163.     procedure RecreateWnd;
  164.     procedure ViewChanged;
  165.   protected
  166.     { Renamed methods }
  167.     function IPersistPropertyBag.InitNew = PersistPropBagInitNew;
  168.     function IPersistPropertyBag.Load = PersistPropBagLoad;
  169.     function IPersistPropertyBag.Save = PersistPropBagSave;
  170.     function IPersistStreamInit.Load = PersistStreamLoad;
  171.     function IPersistStreamInit.Save = PersistStreamSave;
  172.     function IPersistStorage.InitNew = PersistStorageInitNew;
  173.     function IPersistStorage.Load = PersistStorageLoad;
  174.     function IPersistStorage.Save = PersistStorageSave;
  175.     function IViewObject2.GetExtent = ViewObjectGetExtent;
  176.     { IPersist }
  177.     function GetClassID(out classID: TCLSID): HResult; stdcall;
  178.     { IPersistPropertyBag }
  179.     function PersistPropBagInitNew: HResult; stdcall;
  180.     function PersistPropBagLoad(const pPropBag: IPropertyBag;
  181.       const pErrorLog: IErrorLog): HResult; stdcall;
  182.     function PersistPropBagSave(const pPropBag: IPropertyBag; fClearDirty: BOOL;
  183.       fSaveAllProperties: BOOL): HResult; stdcall;
  184.     { IPersistStreamInit }
  185.     function IsDirty: HResult; stdcall;
  186.     function PersistStreamLoad(const stm: IStream): HResult; stdcall;
  187.     function PersistStreamSave(const stm: IStream;
  188.       fClearDirty: BOOL): HResult; stdcall;
  189.     function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
  190.     function InitNew: HResult; stdcall;
  191.     { IPersistStorage }
  192.     function PersistStorageInitNew(const stg: IStorage): HResult; stdcall;
  193.     function PersistStorageLoad(const stg: IStorage): HResult; stdcall;
  194.     function PersistStorageSave(const stgSave: IStorage;
  195.       fSameAsLoad: BOOL): HResult; stdcall;
  196.     function SaveCompleted(const stgNew: IStorage): HResult; stdcall;
  197.     function HandsOffStorage: HResult; stdcall;
  198.     { IObjectSafety }
  199.     function GetInterfaceSafetyOptions(const IID: TIID; pdwSupportedOptions,
  200.       pdwEnabledOptions: PDWORD): HResult; virtual; stdcall;
  201.     function SetInterfaceSafetyOptions(const IID: TIID; dwOptionSetMask,
  202.       dwEnabledOptions: DWORD): HResult; virtual; stdcall;
  203.     { IOleObject }
  204.     function SetClientSite(const clientSite: IOleClientSite): HResult;
  205.       stdcall;
  206.     function GetClientSite(out clientSite: IOleClientSite): HResult;
  207.       stdcall;
  208.     function SetHostNames(szContainerApp: POleStr;
  209.       szContainerObj: POleStr): HResult; stdcall;
  210.     function Close(dwSaveOption: Longint): HResult; stdcall;
  211.     function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
  212.       stdcall;
  213.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  214.       out mk: IMoniker): HResult; stdcall;
  215.     function InitFromData(const dataObject: IDataObject; fCreation: BOOL;
  216.       dwReserved: Longint): HResult; stdcall;
  217.     function GetClipboardData(dwReserved: Longint;
  218.       out dataObject: IDataObject): HResult; stdcall;
  219.     function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
  220.       lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
  221.       stdcall;
  222.     function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;
  223.     function Update: HResult; stdcall;
  224.     function IsUpToDate: HResult; stdcall;
  225.     function GetUserClassID(out clsid: TCLSID): HResult; stdcall;
  226.     function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
  227.       stdcall;
  228.     function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
  229.       stdcall;
  230.     function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
  231.       stdcall;
  232.     function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  233.       stdcall;
  234.     function Unadvise(dwConnection: Longint): HResult; stdcall;
  235.     function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  236.     function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
  237.       stdcall;
  238.     function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;
  239.     { IOleControl }
  240.     function GetControlInfo(var ci: TControlInfo): HResult; stdcall;
  241.     function OnMnemonic(msg: PMsg): HResult; stdcall;
  242.     function OnAmbientPropertyChange(dispid: TDispID): HResult; stdcall;
  243.     function FreezeEvents(bFreeze: BOOL): HResult; stdcall;
  244.     { IOleWindow }
  245.     function GetWindow(out wnd: HWnd): HResult; stdcall;
  246.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  247.     { IOleInPlaceObject }
  248.     function InPlaceDeactivate: HResult; stdcall;
  249.     function UIDeactivate: HResult; stdcall;
  250.     function SetObjectRects(const rcPosRect: TRect;
  251.       const rcClipRect: TRect): HResult; stdcall;
  252.     function ReactivateAndUndo: HResult; stdcall;
  253.     { IOleInPlaceActiveObject }
  254.     function TranslateAccelerator(var msg: TMsg): HResult; stdcall;
  255.     function OnFrameWindowActivate(fActivate: BOOL): HResult; stdcall;
  256.     function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall;
  257.     function ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
  258.       fFrameWindow: BOOL): HResult; stdcall;
  259.     function EnableModeless(fEnable: BOOL): HResult; stdcall;
  260.     { IViewObject }
  261.     function Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  262.       ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
  263.       prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
  264.       dwContinue: Longint): HResult; stdcall;
  265.     function GetColorSet(dwDrawAspect: Longint; lindex: Longint;
  266.       pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
  267.       out colorSet: PLogPalette): HResult; stdcall;
  268.     function Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  269.       out dwFreeze: Longint): HResult; stdcall;
  270.     function Unfreeze(dwFreeze: Longint): HResult; stdcall;
  271.     function SetAdvise(aspects: Longint; advf: Longint;
  272.       const advSink: IAdviseSink): HResult; stdcall;
  273.     function GetAdvise(pAspects: PLongint; pAdvf: PLONGINT;
  274.       out advSink: IAdviseSink): HResult; stdcall;
  275.     { IViewObject2 }
  276.     function ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
  277.       ptd: PDVTargetDevice; out size: TPoint): HResult; stdcall;
  278.     { IPerPropertyBrowsing }
  279.     function GetDisplayString(dispid: TDispID; out bstr: WideString): HResult; stdcall;
  280.     function MapPropertyToPage(dispid: TDispID; out clsid: TCLSID): HResult; stdcall;
  281.     function GetPredefinedStrings(dispid: TDispID; out caStringsOut: TCAPOleStr;
  282.       out caCookiesOut: TCALongint): HResult; stdcall;
  283.     function GetPredefinedValue(dispid: TDispID; dwCookie: Longint;
  284.       out varOut: OleVariant): HResult; stdcall;
  285.     { ISpecifyPropertyPages }
  286.     function GetPages(out pages: TCAGUID): HResult; stdcall;
  287.     { ISimpleFrameSite }
  288.     function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  289.       out res: Integer; out Cookie: Longint): HResult; stdcall;
  290.     function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  291.       out res: Integer; Cookie: Longint): HResult; stdcall;
  292.     { IQuickActivate }
  293.     function QuickActivate(var qaCont: tagQACONTAINER; var qaCtrl: tagQACONTROL): HResult; stdcall;
  294.     function SetContentExtent(const sizel: TPoint): HResult; stdcall;
  295.     function GetContentExtent(out sizel: TPoint): HResult; stdcall;
  296.     { IDataObject }
  297.     function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium):
  298.       HResult; stdcall;
  299.     function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium):
  300.       HResult; stdcall;
  301.     function QueryGetData(const formatetc: TFormatEtc): HResult;
  302.       stdcall;
  303.     function GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  304.       out formatetcOut: TFormatEtc): HResult; stdcall;
  305.     function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  306.       fRelease: BOOL): HResult; stdcall;
  307.     function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
  308.       IEnumFormatEtc): HResult; stdcall;
  309.     function DAdvise(const formatetc: TFormatEtc; advf: Longint;
  310.       const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
  311.     function DUnadvise(dwConnection: Longint): HResult; stdcall;
  312.     function EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
  313.       stdcall;
  314.     { Standard properties }
  315.     function Get_BackColor: Integer; safecall;
  316.     function Get_Caption: WideString; safecall;
  317.     function Get_Enabled: WordBool; safecall;
  318.     function Get_Font: Font; safecall;
  319.     function Get_ForeColor: Integer; safecall;
  320.     function Get_HWnd: Integer; safecall;
  321.     function Get_TabStop: WordBool; safecall;
  322.     function Get_Text: WideString; safecall;
  323.     procedure Set_BackColor(Value: Integer); safecall;
  324.     procedure Set_Caption(const Value: WideString); safecall;
  325.     procedure Set_Enabled(Value: WordBool); safecall;
  326.     procedure Set_Font(const Value: Font); safecall;
  327.     procedure Set_ForeColor(Value: Integer); safecall;
  328.     procedure Set_TabStop(Value: WordBool); safecall;
  329.     procedure Set_Text(const Value: WideString); safecall;
  330.     { Standard event handlers }
  331.     procedure StdClickEvent(Sender: TObject);
  332.     procedure StdDblClickEvent(Sender: TObject);
  333.     procedure StdKeyDownEvent(Sender: TObject; var Key: Word;
  334.       Shift: TShiftState);
  335.     procedure StdKeyPressEvent(Sender: TObject; var Key: Char);
  336.     procedure StdKeyUpEvent(Sender: TObject; var Key: Word;
  337.       Shift: TShiftState);
  338.     procedure StdMouseDownEvent(Sender: TObject; Button: TMouseButton;
  339.       Shift: TShiftState; X, Y: Integer);
  340.     procedure StdMouseMoveEvent(Sender: TObject; Shift: TShiftState;
  341.       X, Y: Integer);
  342.     procedure StdMouseUpEvent(Sender: TObject; Button: TMouseButton;
  343.       Shift: TShiftState; X, Y: Integer);
  344.     { Helper methods }
  345.     function InPlaceActivate(ActivateUI: Boolean): HResult;
  346.     procedure ShowPropertyDialog;
  347.     procedure SetInPlaceSite(const NewInPlaceSite: IOleInPlaceSite);
  348.     { Overrideable methods }
  349.     procedure DefinePropertyPages(
  350.       DefinePropertyPage: TDefinePropertyPage); virtual;
  351.     function GetPropertyString(DispID: Integer;
  352.       var S: string): Boolean; virtual;
  353.     function GetPropertyStrings(DispID: Integer;
  354.       Strings: TStrings): Boolean; virtual;
  355.     procedure GetPropertyValue(DispID, Cookie: Integer;
  356.       var Value: OleVariant); virtual;
  357.     procedure GetPropFromBag(const PropName: WideString; DispatchID: Integer;
  358.       PropBag: IPropertyBag; ErrorLog: IErrorLog); virtual;
  359.     procedure InitializeControl; virtual;
  360.     procedure LoadFromStream(const Stream: IStream); virtual;
  361.     procedure PerformVerb(Verb: Integer); virtual;
  362.     procedure PutPropInBag(const PropName: WideString; DispatchID: Integer;
  363.       PropBag: IPropertyBag); virtual;
  364.     procedure SaveToStream(const Stream: IStream); virtual;
  365.     procedure WndProc(var Message: TMessage); virtual;
  366.     property ConnectionPoints: TConnectionPoints read FConnectionPoints
  367.       implements IConnectionPointContainer;
  368.   public
  369.     destructor Destroy; override;
  370.     procedure Initialize; override;
  371.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  372.     procedure PropChanged(const PropertyName: WideString); overload;
  373.     procedure PropChanged(DispID: TDispID); overload;
  374.     function PropRequestEdit(const PropertyName: WideString): Boolean; overload;
  375.     function PropRequestEdit(DispID: TDispID): Boolean; overload;
  376.     property ClientSite: IOleClientSite read FOleClientSite;
  377.     property InPlaceSite: IOleInPlaceSite read FOleInPlaceSite;
  378.     property Control: TWinControl read FControl;
  379.   end;
  380.   {$EXTERNALSYM TActiveXControl}
  381.  
  382.   TActiveXControlClass = class of TActiveXControl;
  383.   {$EXTERNALSYM TActiveXControlClass}
  384.  
  385.   TActiveXControlFactory = class(TAutoObjectFactory)
  386.   private
  387.     FWinControlClass: TWinControlClass;
  388.     FMiscStatus: Integer;
  389.     FToolboxBitmapID: Integer;
  390.     FVerbs: TStringList;
  391.     FLicFileStrings: TStringList;
  392.     FLicenseFileRead: Boolean;
  393.   protected
  394.     function GetLicenseFileName: string; virtual;
  395.     function HasMachineLicense: Boolean; override;
  396.   public
  397.     constructor Create(ComServer: TComServerObject;
  398.       ActiveXControlClass: TActiveXControlClass;
  399.       WinControlClass: TWinControlClass; const ClassID: TGUID;
  400.       ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer;
  401.       ThreadingModel: TThreadingModel = tmSingle);
  402.     destructor Destroy; override;
  403.     procedure AddVerb(Verb: Integer; const VerbName: string);
  404.     procedure UpdateRegistry(Register: Boolean); override;
  405.     property MiscStatus: Integer read FMiscStatus;
  406.     property ToolboxBitmapID: Integer read FToolboxBitmapID;
  407.     property WinControlClass: TWinControlClass read FWinControlClass;
  408.   end;
  409.   {$EXTERNALSYM TActiveXControlFactory}
  410.  
  411.   { ActiveFormControl }
  412.  
  413.   TActiveFormControl = class(TActiveXControl, IVCLComObject)
  414.   protected
  415.     procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
  416.     procedure EventSinkChanged(const EventSink: IUnknown); override;
  417.   public
  418.     procedure FreeOnRelease;
  419.     procedure InitializeControl; override;
  420.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  421.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  422.       override;
  423.     function ObjQueryInterface(const IID: TGUID; out Obj): HResult; override;
  424.   end;
  425.   {$EXTERNALSYM TActiveFormControl}
  426.  
  427.   { ActiveForm }
  428.  
  429.   TActiveForm = class(TCustomActiveForm)
  430.   private
  431.     FActiveFormControl: TActiveFormControl;
  432.   protected
  433.     procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); virtual;
  434.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  435.     procedure Initialize; virtual;
  436.   public
  437.     property ActiveFormControl: TActiveFormControl read FActiveFormControl;
  438.   end;
  439.   {$EXTERNALSYM TActiveForm}
  440.  
  441.   TActiveFormClass = class of TActiveForm;
  442.   {$EXTERNALSYM TActiveFormClass}
  443.  
  444.   { ActiveFormFactory }
  445.  
  446.   TActiveFormFactory = class(TActiveXControlFactory)
  447.   public
  448.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; override;
  449.   end;
  450.   {$EXTERNALSYM TActiveFormFactory}
  451.  
  452.   { Property Page support }
  453.  
  454.   TPropertyPageImpl = class;
  455.  
  456.   TPropertyPage = class(TCustomForm)
  457.   private
  458.     FActiveXPropertyPage: TPropertyPageImpl;
  459.     FOleObject: OleVariant;
  460.     FOleObjects: TInterfaceList;
  461.     procedure CMChanged(var Msg: TCMChanged); message CM_CHANGED;
  462.   public
  463.     constructor Create(AOwner: TComponent); override;
  464.     destructor Destroy; override;
  465.     procedure Modified;
  466.     procedure UpdateObject; virtual;
  467.     procedure UpdatePropertyPage; virtual;
  468.     property OleObject: OleVariant read FOleObject;
  469.     property OleObjects: TInterfaceList read FOleObjects write FOleObjects;
  470.     procedure EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  471.   published
  472.     property ActiveControl;
  473.     property AutoScroll;
  474.     property Caption;
  475.     property ClientHeight;
  476.     property ClientWidth;
  477.     property Ctl3D;
  478.     property Color;
  479.     property Enabled;
  480.     property Font;
  481.     property Height;
  482.     property HorzScrollBar;
  483.     property OldCreateOrder;
  484.     property KeyPreview;
  485.     property PixelsPerInch;
  486.     property ParentFont;
  487.     property PopupMenu;
  488.     property PrintScale;
  489.     property Scaled;
  490.     property ShowHint;
  491.     property VertScrollBar;
  492.     property Visible;
  493.     property Width;
  494.     property OnActivate;
  495.     property OnClick;
  496.     property OnClose;
  497.     property OnContextPopup;
  498.     property OnCreate;
  499.     property OnDblClick;
  500.     property OnDestroy;
  501.     property OnDeactivate;
  502.     property OnDragDrop;
  503.     property OnDragOver;
  504.     property OnHide;
  505.     property OnKeyDown;
  506.     property OnKeyPress;
  507.     property OnKeyUp;
  508.     property OnMouseDown;
  509.     property OnMouseMove;
  510.     property OnMouseUp;
  511.     property OnPaint;
  512.     property OnResize;
  513.     property OnShow;
  514.   end;
  515.  
  516.   TPropertyPageClass = class of TPropertyPage;
  517.  
  518.   TPropertyPageImpl = class(TAggregatedObject, IUnknown, IPropertyPage, IPropertyPage2)
  519.   private
  520.     FPropertyPage: TPropertyPage;
  521.     FPageSite: IPropertyPageSite;
  522.     FActive: Boolean;
  523.     FModified: Boolean;
  524.     procedure Modified;
  525.   protected
  526.     { IPropertyPage }
  527.     function SetPageSite(const pageSite: IPropertyPageSite): HResult; stdcall;
  528.     function Activate(hwndParent: HWnd; const rc: TRect; bModal: BOOL): HResult;
  529.       stdcall;
  530.     function Deactivate: HResult; stdcall;
  531.     function GetPageInfo(out pageInfo: TPropPageInfo): HResult; stdcall;
  532.     function SetObjects(cObjects: Longint; pUnkList: PUnknownList): HResult; stdcall;
  533.     function Show(nCmdShow: Integer): HResult; stdcall;
  534.     function Move(const rect: TRect): HResult; stdcall;
  535.     function IsPageDirty: HResult; stdcall;
  536.     function Apply: HResult; stdcall;
  537.     function Help(pszHelpDir: POleStr): HResult; stdcall;
  538.     function TranslateAccelerator(msg: PMsg): HResult; stdcall;
  539.     { IPropertyPage2 }
  540.     function EditProperty(dispid: TDispID): HResult; stdcall;
  541.   public
  542.     procedure InitPropertyPage; virtual;
  543.     property PropertyPage: TPropertyPage read FPropertyPage write FPropertyPage;
  544.   end;
  545.  
  546.   TActiveXPropertyPage = class(TComObject, IPropertyPage, IPropertyPage2)
  547.   private
  548.     FPropertyPageImpl: TPropertyPageImpl;
  549.   public
  550.     destructor Destroy; override;
  551.     procedure Initialize; override;
  552.     property PropertyPageImpl: TPropertyPageImpl read FPropertyPageImpl
  553.       implements IPropertyPage, IPropertyPage2;
  554.   end;
  555.   {$EXTERNALSYM TActiveXPropertyPage}
  556.  
  557.   TActiveXPropertyPageFactory = class(TComObjectFactory)
  558.   public
  559.     constructor Create(ComServer: TComServerObject;
  560.       PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
  561.     function CreateComObject(const Controller: IUnknown): TComObject; override;
  562.   end;
  563.   {$EXTERNALSYM TActiveXPropertyPageFactory}
  564.  
  565.   { Type adapter support }
  566.  
  567.   TCustomAdapter = class(TInterfacedObject)
  568.   private
  569.     FOleObject: IUnknown;
  570.     FConnection: Longint;
  571.     FNotifier: IUnknown;
  572.   protected
  573.     Updating: Boolean;
  574.     procedure Changed; virtual;
  575.     procedure ConnectOleObject(OleObject: IUnknown);
  576.     procedure ReleaseOleObject;
  577.     procedure Update; virtual; abstract;
  578.   public
  579.     constructor Create;
  580.     destructor Destroy; override;
  581.   end;
  582.  
  583.   TAdapterNotifier = class(TInterfacedObject,
  584.     IPropertyNotifySink)
  585.   private
  586.     FAdapter: TCustomAdapter;
  587.   protected
  588.     { IPropertyNotifySink }
  589.     function OnChanged(dispid: TDispID): HResult; stdcall;
  590.     function OnRequestEdit(dispid: TDispID): HResult; stdcall;
  591.   public
  592.     constructor Create(Adapter: TCustomAdapter);
  593.   end;
  594.  
  595.   IFontAccess = interface
  596.     ['{CBA55CA0-0E57-11D0-BD2F-0020AF0E5B81}']
  597.     procedure GetOleFont(var OleFont: IFontDisp);
  598.     procedure SetOleFont(const OleFont: IFontDisp);
  599.   end;
  600.  
  601.   TFontAdapter = class(TCustomAdapter,
  602.     IChangeNotifier,
  603.     IFontAccess)
  604.   private
  605.     FFont: TFont;
  606.   protected
  607.     { IFontAccess }
  608.     procedure GetOleFont(var OleFont: IFontDisp);
  609.     procedure SetOleFont(const OleFont: IFontDisp);
  610.     procedure Changed; override;
  611.     procedure Update; override;
  612.   public
  613.     constructor Create(Font: TFont);
  614.   end;
  615.  
  616.   IPictureAccess = interface
  617.     ['{795D4D31-43D7-11D0-9E92-0020AF3D82DA}']
  618.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  619.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  620.   end;
  621.  
  622.   TPictureAdapter = class(TCustomAdapter,
  623.     IChangeNotifier,
  624.     IPictureAccess)
  625.   private
  626.     FPicture: TPicture;
  627.   protected
  628.     { IPictureAccess }
  629.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  630.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  631.     procedure Update; override;
  632.   public
  633.     constructor Create(Picture: TPicture);
  634.   end;
  635.  
  636.   TOleGraphic = class(TGraphic)
  637.   private
  638.     FPicture: IPicture;
  639.     function GetMMHeight: Integer;
  640.     function GetMMWidth: Integer;
  641.   protected
  642.     procedure Changed(Sender: TObject); override;
  643.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  644.     function GetEmpty: Boolean; override;
  645.     function GetHeight: Integer; override;
  646.     function GetPalette: HPALETTE; override;
  647.     function GetTransparent: Boolean; override;
  648.     function GetWidth: Integer; override;
  649.     procedure SetHeight(Value: Integer); override;
  650.     procedure SetPalette(Value: HPALETTE); override;
  651.     procedure SetWidth(Value: Integer); override;
  652.   public
  653.     procedure Assign(Source: TPersistent); override;
  654.     procedure LoadFromFile(const Filename: string); override;
  655.     procedure LoadFromStream(Stream: TStream); override;
  656.     procedure SaveToStream(Stream: TStream); override;
  657.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  658.       APalette: HPALETTE); override;
  659.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  660.       var APalette: HPALETTE); override;
  661.     property MMHeight: Integer read GetMMHeight;      // in .01 mm units
  662.     property MMWidth: Integer read GetMMWidth;
  663.     property Picture: IPicture read FPicture write FPicture;
  664.   end;
  665.  
  666.   TStringsAdapter = class(TAutoIntfObject, IStrings, IStringsAdapter)
  667.   private
  668.     FStrings: TStrings;
  669.   protected
  670.     { IStringsAdapter }
  671.     procedure ReferenceStrings(S: TStrings);
  672.     procedure ReleaseStrings;
  673.     { IStrings }
  674.     function Get_ControlDefault(Index: Integer): OleVariant; safecall;
  675.     procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall;
  676.     function Count: Integer; safecall;
  677.     function Get_Item(Index: Integer): OleVariant; safecall;
  678.     procedure Set_Item(Index: Integer; Value: OleVariant); safecall;
  679.     procedure Remove(Index: Integer); safecall;
  680.     procedure Clear; safecall;
  681.     function Add(Item: OleVariant): Integer; safecall;
  682.     function _NewEnum: IUnknown; safecall;
  683.   public
  684.     constructor Create(Strings: TStrings);
  685.   end;
  686.  
  687.   TReflectorWindow = class(TWinControl)
  688.   private
  689.     FControl: TControl;
  690.     FInSize: Boolean;
  691.     procedure WMGetDlgCode(var Message: TMessage); message WM_GETDLGCODE;
  692.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  693.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  694.   public
  695.     constructor Create(ParentWindow: HWND; Control: TControl); reintroduce;
  696.   end;
  697.  
  698. function GetDispatchPropValue(Disp: IDispatch; DispID: Integer): OleVariant;
  699. procedure SetDispatchPropValue(Disp: IDispatch; DispID: Integer;
  700.   const Value: OleVariant);
  701. procedure EnumDispatchProperties(Dispatch: IDispatch; PropType: TGUID;
  702.   VTCode: Integer; PropList: TStrings);
  703.  
  704. procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
  705. procedure SetOleFont(Font: TFont; OleFont: IFontDisp);
  706. procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
  707. procedure SetOlePicture(Picture: TPicture; OlePicture: IPictureDisp);
  708. procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
  709. procedure SetOleStrings(Strings: TStrings; OleStrings: IStrings);
  710.  
  711. function ParkingWindow: HWND;
  712.  
  713. implementation
  714.  
  715. uses Consts;
  716.  
  717. const
  718.   OCM_BASE = $2000;
  719.  
  720. type
  721.   TWinControlAccess = class(TWinControl);
  722.  
  723.   IStdEvents = dispinterface
  724.     ['{00020400-0000-0000-C000-000000000046}']
  725.     procedure Click; dispid DISPID_CLICK;
  726.     procedure DblClick; dispid DISPID_DBLCLICK;
  727.     procedure KeyDown(var KeyCode: Smallint;
  728.       Shift: Smallint); dispid DISPID_KEYDOWN;
  729.     procedure KeyPress(var KeyAscii: Smallint); dispid DISPID_KEYPRESS;
  730.     procedure KeyUp(var KeyCode: Smallint;
  731.       Shift: Smallint); dispid DISPID_KEYDOWN;
  732.     procedure MouseDown(Button, Shift: Smallint;
  733.       X, Y: Integer); dispid DISPID_MOUSEDOWN;
  734.     procedure MouseMove(Button, Shift: Smallint;
  735.       X, Y: Integer); dispid DISPID_MOUSEMOVE;
  736.     procedure MouseUp(Button, Shift: Smallint;
  737.       X, Y: Integer); dispid DISPID_MOUSEUP;
  738.   end;
  739.  
  740. var
  741.   xParkingWindow: HWND;
  742.  
  743. { Dynamically load functions used in OLEPRO32.DLL }
  744.  
  745. function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
  746.   lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  747.   pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  748.   pvReserved: Pointer): HResult; forward;
  749. function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
  750.   out vObject): HResult; forward;
  751. function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
  752.   fOwn: BOOL; out vObject): HResult; forward;
  753. function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
  754.   const iid: TIID; out vObject): HResult; forward;
  755.  
  756.  
  757. function ParkingWindowProc(Wnd: HWND; Msg, wParam, lParam: Longint): Longint; stdcall;
  758. var
  759.   ControlWnd: HWND;
  760. begin
  761.   case Msg of
  762.     WM_COMPAREITEM, WM_DELETEITEM, WM_DRAWITEM, WM_MEASUREITEM, WM_COMMAND:
  763.       begin
  764.         case Msg of
  765.           WM_COMPAREITEM: ControlWnd := PCompareItemStruct(lParam).CtlID;
  766.           WM_DELETEITEM:  ControlWnd := PDeleteItemStruct(lParam).CtlID;
  767.           WM_DRAWITEM:    ControlWnd := PDrawItemStruct(lParam).CtlID;
  768.           WM_MEASUREITEM: ControlWnd := PMeasureItemStruct(lParam).CtlID;
  769.           WM_COMMAND:     ControlWnd := HWND(lParam);
  770.         else
  771.           Result := 0;
  772.           Exit;
  773.         end;
  774.         Result := SendMessage(ControlWnd, OCM_BASE + Msg, wParam, lParam);
  775.       end;
  776.   else
  777.     if (Msg = WM_NCDESTROY) and (Wnd = xParkingWindow) then xParkingWindow := 0;
  778.     Result := DefWindowProc(Wnd, Msg, WParam, LParam);
  779.   end;
  780. end;
  781.  
  782. function ParkingWindow: HWND;
  783. var
  784.   TempClass: TWndClass;
  785. begin
  786.   Result := xParkingWindow;
  787.   if Result <> 0 then Exit;
  788.  
  789.   FillChar(TempClass, sizeof(TempClass), 0);
  790.   if not GetClassInfo(HInstance, 'DAXParkingWindow', TempClass) then
  791.   begin
  792.     TempClass.hInstance := HInstance;
  793.     TempClass.lpfnWndProc := @ParkingWindowProc;
  794.     TempClass.lpszClassName := 'DAXParkingWindow';
  795.     if Windows.RegisterClass(TempClass) = 0 then
  796.       raise EOutOfResources.Create(SWindowClass);
  797.   end;
  798.   xParkingWindow := CreateWindowEx(WS_EX_TOOLWINDOW, TempClass.lpszClassName, nil,
  799.     WS_POPUP, GetSystemMetrics(SM_CXSCREEN) div 2,
  800.     GetSystemMetrics(SM_CYSCREEN) div 2, 0, 0, 0, 0, HInstance, nil);
  801.   SetWindowPos(xParkingWindow, 0, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOREDRAW
  802.     or SWP_NOZORDER or SWP_SHOWWINDOW);
  803.   Result := xParkingWindow;
  804. end;
  805.  
  806. function HandleException: HResult;
  807. var
  808.   E: TObject;
  809. begin
  810.   E := ExceptObject;
  811.   if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
  812.     Result := EOleSysError(E).ErrorCode else
  813.     Result := E_UNEXPECTED;
  814. end;
  815.  
  816. procedure FreeObjects(List: TList);
  817. var
  818.   I: Integer;
  819. begin
  820.   for I := List.Count - 1 downto 0 do TObject(List[I]).Free;
  821. end;
  822.  
  823. procedure FreeObjectList(List: TList);
  824. begin
  825.   if List <> nil then
  826.   begin
  827.     FreeObjects(List);
  828.     List.Free;
  829.   end;
  830. end;
  831.  
  832. function CoAllocMem(Size: Integer): Pointer;
  833. begin
  834.   Result := CoTaskMemAlloc(Size);
  835.   if Result = nil then OleError(E_OUTOFMEMORY);
  836.   FillChar(Result^, Size, 0);
  837. end;
  838.  
  839. procedure CoFreeMem(P: Pointer);
  840. begin
  841.   if P <> nil then CoTaskMemFree(P);
  842. end;
  843.  
  844. function CoAllocString(const S: string): POleStr;
  845. var
  846.   W: WideString;
  847.   Size: Integer;
  848. begin
  849.   W := S;
  850.   Size := (Length(W) + 1) * 2;
  851.   Result := CoAllocMem(Size);
  852.   Move(PWideChar(W)^, Result^, Size);
  853. end;
  854.  
  855. { Get/Set raw Dispatch properties }
  856.  
  857. const
  858.   DispIDArgs: Longint = DISPID_PROPERTYPUT;
  859.  
  860. function GetDispatchPropValue(Disp: IDispatch; DispID: Integer): OleVariant;
  861. var
  862.   ExcepInfo: TExcepInfo;
  863.   DispParams: TDispParams;
  864.   Status: HResult;
  865. begin
  866.   FillChar(DispParams, SizeOf(DispParams), 0);
  867.   Status := Disp.Invoke(DispID, GUID_NULL, 0, DISPATCH_PROPERTYGET, DispParams,
  868.     @Result, @ExcepInfo, nil);
  869.   if Status <> S_OK then DispatchInvokeError(Status, ExcepInfo);
  870. end;
  871.  
  872. procedure SetDispatchPropValue(Disp: IDispatch; DispID: Integer;
  873.   const Value: OleVariant);
  874. var
  875.   ExcepInfo: TExcepInfo;
  876.   DispParams: TDispParams;
  877.   Status: HResult;
  878. begin
  879.   with DispParams do
  880.   begin
  881.     rgvarg := @Value;
  882.     rgdispidNamedArgs := @DispIDArgs;
  883.     cArgs := 1;
  884.     cNamedArgs := 1;
  885.   end;
  886.   Status := Disp.Invoke(DispId, GUID_NULL, 0, DISPATCH_PROPERTYPUT, DispParams,
  887.     nil, @ExcepInfo, nil);
  888.   if Status <> S_OK then DispatchInvokeError(Status, ExcepInfo);
  889. end;
  890.  
  891. { Fill list with properties of a given IDispatch }
  892.  
  893. procedure EnumDispatchProperties(Dispatch: IDispatch; PropType: TGUID;
  894.   VTCode: Integer; PropList: TStrings);
  895. const
  896.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  897. var
  898.   I: Integer;
  899.   TypeInfo: ITypeInfo;
  900.   TypeAttr: PTypeAttr;
  901.   FuncDesc: PFuncDesc;
  902.   VarDesc: PVarDesc;
  903.  
  904.   procedure SaveName(Id: Integer);
  905.   var
  906.     Name: WideString;
  907.   begin
  908.     OleCheck(TypeInfo.GetDocumentation(Id, @Name, nil, nil, nil));
  909.     if PropList.IndexOfObject(TObject(Id)) = -1 then
  910.       PropList.AddObject(Name, TObject(Id));
  911.   end;
  912.  
  913.   function IsPropType(const TypeInfo: ITypeInfo; TypeDesc: PTypeDesc): Boolean;
  914.   var
  915.     RefInfo: ITypeInfo;
  916.     RefAttr: PTypeAttr;
  917.     IsNullGuid: Boolean;
  918.   begin
  919.     IsNullGuid := IsEqualGuid(PropType, GUID_NULL);
  920.     Result := IsNullGuid and (VTCode = VT_EMPTY);
  921.     if Result then Exit;
  922.     case TypeDesc.vt of
  923.       VT_PTR: Result := IsPropType(TypeInfo, TypeDesc.ptdesc);
  924.       VT_USERDEFINED:
  925.         begin
  926.           OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
  927.           OleCheck(RefInfo.GetTypeAttr(RefAttr));
  928.           try
  929.             Result := IsEqualGUID(RefAttr.guid, PropType);
  930.             if not Result and (RefAttr.typekind = TKIND_ALIAS) then
  931.               Result := IsPropType(RefInfo, @RefAttr.tdescAlias);
  932.           finally
  933.             RefInfo.ReleaseTypeAttr(RefAttr);
  934.           end;
  935.         end;
  936.     else
  937.       Result := IsNullGuid and (TypeDesc.vt = VTCode);
  938.     end;
  939.   end;
  940.  
  941.   function HasMember(const TypeInfo: ITypeInfo; Cnt, MemID, InvKind: Integer): Boolean;
  942.   var
  943.     I: Integer;
  944.     FuncDesc: PFuncDesc;
  945.   begin
  946.     for I := 0 to Cnt - 1 do
  947.     begin
  948.       OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
  949.       try
  950.         if (FuncDesc.memid = MemID) and (FuncDesc.invkind and InvKind <> 0) then
  951.         begin
  952.           Result := True;
  953.           Exit;
  954.         end;
  955.       finally
  956.         TypeInfo.ReleaseFuncDesc(FuncDesc);
  957.       end;
  958.     end;
  959.     Result := False;
  960.   end;
  961.  
  962. begin
  963.   OleCheck(Dispatch.GetTypeInfo(0,0,TypeInfo));
  964.   if TypeInfo = nil then Exit;
  965.   OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  966.   try
  967.     for I := 0 to TypeAttr.cVars - 1 do
  968.     begin
  969.       OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  970.       try
  971.         if (VarDesc.wVarFlags and VARFLAG_FREADONLY <> 0) and
  972.           IsPropType(TypeInfo, @VarDesc.elemdescVar.tdesc) then
  973.           SaveName(VarDesc.memid);
  974.       finally
  975.         TypeInfo.ReleaseVarDesc(VarDesc);
  976.       end;
  977.     end;
  978.     for I := 0 to TypeAttr.cFuncs - 1 do
  979.     begin
  980.       OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
  981.       try
  982.         if ((FuncDesc.invkind = INVOKE_PROPERTYGET) and
  983.           HasMember(TypeInfo, TypeAttr.cFuncs, FuncDesc.memid, INVOKE_PROPERTYSET) and
  984.           IsPropType(TypeInfo, @FuncDesc.elemdescFunc.tdesc)) or
  985.           ((FuncDesc.invkind and INVOKE_PROPERTYSET <> 0) and
  986.           HasMember(TypeInfo, TypeAttr.cFuncs, FuncDesc.memid, INVOKE_PROPERTYGET) and
  987.           IsPropType(TypeInfo,
  988.             @FuncDesc.lprgelemdescParam[FuncDesc.cParams - 1].tdesc)) then
  989.             SaveName(FuncDesc.memid);
  990.       finally
  991.         TypeInfo.ReleaseFuncDesc(FuncDesc);
  992.       end;
  993.     end;
  994.   finally
  995.     TypeInfo.ReleaseTypeAttr(TypeAttr);
  996.   end;
  997. end;
  998.  
  999. { Font and Picture support }
  1000.  
  1001. function GetFontAccess(Font: TFont): IFontAccess;
  1002. begin
  1003.   if Font.FontAdapter = nil then
  1004.     Font.FontAdapter := TFontAdapter.Create(Font);
  1005.   Result := Font.FontAdapter as IFontAccess;
  1006. end;
  1007.  
  1008. function GetPictureAccess(Picture: TPicture): IPictureAccess;
  1009. begin
  1010.   if Picture.PictureAdapter = nil then
  1011.     Picture.PictureAdapter := TPictureAdapter.Create(Picture);
  1012.   Result := Picture.PictureAdapter as IPictureAccess;
  1013. end;
  1014.  
  1015. procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
  1016. begin
  1017.   GetFontAccess(Font).GetOleFont(OleFont);
  1018. end;
  1019.  
  1020. procedure SetOleFont(Font: TFont; OleFont: IFontDisp);
  1021. begin
  1022.   GetFontAccess(Font).SetOleFont(OleFont);
  1023. end;
  1024.  
  1025. procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
  1026. begin
  1027.   GetPictureAccess(Picture).GetOlePicture(OlePicture);
  1028. end;
  1029.  
  1030. procedure SetOlePicture(Picture: TPicture; OlePicture: IPictureDisp);
  1031. begin
  1032.   GetPictureAccess(Picture).SetOlePicture(OlePicture);
  1033. end;
  1034.  
  1035. function GetKeyModifiers: Integer;
  1036. begin
  1037.   Result := 0;
  1038.   if GetKeyState(VK_SHIFT) < 0 then Result := 1;
  1039.   if GetKeyState(VK_CONTROL) < 0 then Result := Result or 2;
  1040.   if GetKeyState(VK_MENU) < 0 then Result := Result or 4;
  1041. end;
  1042.  
  1043. function GetEventShift(Shift: TShiftState): Integer;
  1044. const
  1045.   ShiftMap: array[0..7] of Byte = (0, 1, 4, 5, 2, 3, 6, 7);
  1046. begin
  1047.   Result := ShiftMap[Byte(Shift) and 7];
  1048. end;
  1049.  
  1050. function GetEventButton(Button: TMouseButton): Integer;
  1051. begin
  1052.   Result := 1 shl Ord(Button);
  1053. end;
  1054.  
  1055. { TOleStream }
  1056.  
  1057. constructor TOleStream.Create(const Stream: IStream);
  1058. begin
  1059.   FStream := Stream;
  1060. end;
  1061.  
  1062. function TOleStream.Read(var Buffer; Count: Longint): Longint;
  1063. begin
  1064.   OleCheck(FStream.Read(@Buffer, Count, @Result));
  1065. end;
  1066.  
  1067. function TOleStream.Seek(Offset: Longint; Origin: Word): Longint;
  1068. var
  1069.   Pos: Largeint;
  1070. begin
  1071.   OleCheck(FStream.Seek(Offset, Origin, Pos));
  1072.   Result := Longint(Pos);
  1073. end;
  1074.  
  1075. function TOleStream.Write(const Buffer; Count: Longint): Longint;
  1076. begin
  1077.   OleCheck(FStream.Write(@Buffer, Count, @Result));
  1078. end;
  1079.  
  1080. function TOleStream.GetIStream: IStream;
  1081. begin
  1082.   Result := FStream;
  1083. end;
  1084.  
  1085. { TEnumConnections }
  1086.  
  1087. type
  1088.   TEnumConnections = class(TInterfacedObject, IEnumConnections)
  1089.   private
  1090.     FConnectionPoint: TConnectionPoint;
  1091.     FController: IUnknown;
  1092.     FIndex: Integer;
  1093.     FCount: Integer;
  1094.   protected
  1095.     { IEnumConnections }
  1096.     function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
  1097.     function Skip(celt: Longint): HResult; stdcall;
  1098.     function Reset: HResult; stdcall;
  1099.     function Clone(out enumconn: IEnumConnections): HResult; stdcall;
  1100.   public
  1101.     constructor Create(ConnectionPoint: TConnectionPoint; Index: Integer);
  1102.   end;
  1103.  
  1104. constructor TEnumConnections.Create(ConnectionPoint: TConnectionPoint;
  1105.   Index: Integer);
  1106. begin
  1107.   inherited Create;
  1108.   FConnectionPoint := ConnectionPoint;
  1109.   // keep ConnectionPoint's controller alive as long as we're in use
  1110.   FController := FConnectionPoint.Controller;
  1111.   FIndex := Index;
  1112.   FCount := ConnectionPoint.FSinkList.Count;
  1113. end;
  1114.  
  1115. { TEnumConnections.IEnumConnections }
  1116.  
  1117. function TEnumConnections.Next(celt: Longint; out elt;
  1118.   pceltFetched: PLongint): HResult;
  1119. type
  1120.   TConnectDatas = array[0..1023] of TConnectData;
  1121. var
  1122.   I: Integer;
  1123.   P: Pointer;
  1124. begin
  1125.   I := 0;
  1126.   while (I < celt) and (FIndex < FCount) do
  1127.   begin
  1128.     P := FConnectionPoint.FSinkList[FIndex];
  1129.     if P <> nil then
  1130.     begin
  1131.       Pointer(TConnectDatas(elt)[I].pUnk) := nil;
  1132.       TConnectDatas(elt)[I].pUnk := IUnknown(P);
  1133.       TConnectDatas(elt)[I].dwCookie := FIndex + 1;
  1134.       Inc(I);
  1135.     end;
  1136.     Inc(FIndex);
  1137.   end;
  1138.   if pceltFetched <> nil then pceltFetched^ := I;
  1139.   if I = celt then Result := S_OK else Result := S_FALSE;
  1140. end;
  1141.  
  1142. function TEnumConnections.Skip(celt: Longint): HResult; stdcall;
  1143. begin
  1144.   Result := S_FALSE;
  1145.   while (celt > 0) and (FIndex < FCount) do
  1146.   begin
  1147.     if FConnectionPoint.FSinkList[FIndex] <> nil then Dec(celt);
  1148.     Inc(FIndex);
  1149.   end;
  1150.   if celt = 0 then Result := S_OK;
  1151. end;
  1152.  
  1153. function TEnumConnections.Reset: HResult; stdcall;
  1154. begin
  1155.   FIndex := 0;
  1156.   Result := S_OK;
  1157. end;
  1158.  
  1159. function TEnumConnections.Clone(out enumconn: IEnumConnections): HResult; stdcall;
  1160. begin
  1161.   try
  1162.     enumconn := TEnumConnections.Create(FConnectionPoint, FIndex);
  1163.     Result := S_OK;
  1164.   except
  1165.     Result := E_UNEXPECTED;
  1166.   end;
  1167. end;
  1168.  
  1169. { TConnectionPoint }
  1170.  
  1171. constructor TConnectionPoint.Create(Container: TConnectionPoints;
  1172.   const IID: TGUID; Kind: TConnectionKind;
  1173.   OnConnect: TConnectEvent);
  1174. begin
  1175.   inherited Create(IUnknown(Container.FController));
  1176.   FContainer := Container;
  1177.   FContainer.FConnectionPoints.Add(Self);
  1178.   FSinkList := TList.Create;
  1179.   FIID := IID;
  1180.   FKind := Kind;
  1181.   FOnConnect := OnConnect;
  1182. end;
  1183.  
  1184. destructor TConnectionPoint.Destroy;
  1185. var
  1186.   I: Integer;
  1187. begin
  1188.   if FContainer <> nil then FContainer.FConnectionPoints.Remove(Self);
  1189.   if FSinkList <> nil then
  1190.   begin
  1191.     for I := 0 to FSinkList.Count - 1 do
  1192.       if FSinkList[I] <> nil then RemoveSink(I);
  1193.     FSinkList.Free;
  1194.   end;
  1195.   inherited Destroy;
  1196. end;
  1197.  
  1198. function TConnectionPoint.AddSink(const Sink: IUnknown): Integer;
  1199. var
  1200.   I: Integer;
  1201. begin
  1202.   I := 0;
  1203.   while I < FSinkList.Count do
  1204.     if FSinkList[I] = nil then Break else Inc(I);
  1205.   if I >= FSinkList.Count then
  1206.     FSinkList.Add(Pointer(Sink)) else
  1207.     FSinkList[I] := Pointer(Sink);
  1208.   Sink._AddRef;
  1209.   Result := I;
  1210. end;
  1211.  
  1212. procedure TConnectionPoint.RemoveSink(Cookie: Longint);
  1213. var
  1214.   Sink: Pointer;
  1215. begin
  1216.   Sink := FSinkList[Cookie];
  1217.   FSinkList[Cookie] := nil;
  1218.   IUnknown(Sink)._Release;
  1219. end;
  1220.  
  1221. { TConnectionPoint.IConnectionPoint }
  1222.  
  1223. function TConnectionPoint.GetConnectionInterface(out iid: TIID): HResult;
  1224. begin
  1225.   iid := FIID;
  1226.   Result := S_OK;
  1227. end;
  1228.  
  1229. function TConnectionPoint.GetConnectionPointContainer(
  1230.   out cpc: IConnectionPointContainer): HResult;
  1231. begin
  1232.   cpc := IUnknown(FContainer.FController) as IConnectionPointContainer;
  1233.   Result := S_OK;
  1234. end;
  1235.  
  1236. function TConnectionPoint.Advise(const unkSink: IUnknown;
  1237.   out dwCookie: Longint): HResult;
  1238. begin
  1239.   if (FKind = ckSingle) and (FSinkList.Count > 0) and
  1240.     (FSinkList[0] <> nil) then
  1241.   begin
  1242.     Result := CONNECT_E_CANNOTCONNECT;
  1243.     Exit;
  1244.   end;
  1245.   try
  1246.     if Assigned(FOnConnect) then FOnConnect(unkSink, True);
  1247.     dwCookie := AddSink(unkSink) + 1;
  1248.     Result := S_OK;
  1249.   except
  1250.     Result := HandleException;
  1251.   end;
  1252. end;
  1253.  
  1254. function TConnectionPoint.Unadvise(dwCookie: Longint): HResult;
  1255. begin
  1256.   Dec(dwCookie);
  1257.   if (dwCookie < 0) or (dwCookie >= FSinkList.Count) or
  1258.     (FSinkList[dwCookie] = nil) then
  1259.   begin
  1260.     Result := CONNECT_E_NOCONNECTION;
  1261.     Exit;
  1262.   end;
  1263.   try
  1264.     if Assigned(FOnConnect) then
  1265.       FOnConnect(IUnknown(FSinkList[dwCookie]), False);
  1266.     RemoveSink(dwCookie);
  1267.     Result := S_OK;
  1268.   except
  1269.     Result := HandleException;
  1270.   end;
  1271. end;
  1272.  
  1273. function TConnectionPoint.EnumConnections(out enumconn: IEnumConnections): HResult;
  1274. begin
  1275.   try
  1276.     enumconn := TEnumConnections.Create(Self, 0);
  1277.     Result := S_OK;
  1278.   except
  1279.     Result := HandleException;
  1280.   end;
  1281. end;
  1282.  
  1283. { TEnumConnectionPoints }
  1284.  
  1285. type
  1286.   TEnumConnectionPoints = class(TContainedObject, IEnumConnectionPoints)
  1287.   private
  1288.     FContainer: TConnectionPoints;
  1289.     FIndex: Integer;
  1290.   protected
  1291.     { IEnumConnectionPoints }
  1292.     function Next(celt: Longint; out elt;
  1293.       pceltFetched: PLongint): HResult; stdcall;
  1294.     function Skip(celt: Longint): HResult; stdcall;
  1295.     function Reset: HResult; stdcall;
  1296.     function Clone(out enumconn: IEnumConnectionPoints): HResult; stdcall;
  1297.   public
  1298.     constructor Create(Container: TConnectionPoints;
  1299.       Index: Integer);
  1300.   end;
  1301.  
  1302. constructor TEnumConnectionPoints.Create(Container: TConnectionPoints;
  1303.   Index: Integer);
  1304. begin
  1305.   inherited Create(IUnknown(Container.FController));
  1306.   FContainer := Container;
  1307.   FIndex := Index;
  1308. end;
  1309.  
  1310. { TEnumConnectionPoints.IEnumConnectionPoints }
  1311.  
  1312. type
  1313.   TPointerList = array[0..0] of Pointer;
  1314.  
  1315. function TEnumConnectionPoints.Next(celt: Longint; out elt;
  1316.   pceltFetched: PLongint): HResult;
  1317. var
  1318.   I: Integer;
  1319.   P: Pointer;
  1320. begin
  1321.   I := 0;
  1322.   while (I < celt) and (FIndex < FContainer.FConnectionPoints.Count) do
  1323.   begin
  1324.     P := Pointer(IConnectionPoint(TConnectionPoint(
  1325.       FContainer.FConnectionPoints[FIndex])));
  1326.     IConnectionPoint(P)._AddRef;
  1327.     TPointerList(elt)[I] := P;
  1328.     Inc(I);
  1329.     Inc(FIndex);
  1330.   end;
  1331.   if pceltFetched <> nil then pceltFetched^ := I;
  1332.   if I = celt then Result := S_OK else Result := S_FALSE;
  1333. end;
  1334.  
  1335. function TEnumConnectionPoints.Skip(celt: Longint): HResult; stdcall;
  1336. begin
  1337.   if FIndex + celt <= FContainer.FConnectionPoints.Count then
  1338.   begin
  1339.     FIndex := FIndex + celt;
  1340.     Result := S_OK;
  1341.   end else
  1342.   begin
  1343.     FIndex := FContainer.FConnectionPoints.Count;
  1344.     Result := S_FALSE;
  1345.   end;
  1346. end;
  1347.  
  1348. function TEnumConnectionPoints.Reset: HResult; stdcall;
  1349. begin
  1350.   FIndex := 0;
  1351.   Result := S_OK;
  1352. end;
  1353.  
  1354. function TEnumConnectionPoints.Clone(
  1355.   out enumconn: IEnumConnectionPoints): HResult; stdcall;
  1356. begin
  1357.   try
  1358.     enumconn := TEnumConnectionPoints.Create(FContainer, FIndex);
  1359.     Result := S_OK;
  1360.   except
  1361.     Result := E_UNEXPECTED;
  1362.   end;
  1363. end;
  1364.  
  1365. { TConnectionPoints }
  1366.  
  1367. constructor TConnectionPoints.Create(const AController: IUnknown);
  1368. begin    // weak reference, don't keep the controller alive
  1369.   FController := Pointer(AController);
  1370.   FConnectionPoints := TList.Create;
  1371. end;
  1372.  
  1373. destructor TConnectionPoints.Destroy;
  1374. begin
  1375.   FreeObjectList(FConnectionPoints);
  1376.   inherited Destroy;
  1377. end;
  1378.  
  1379. function TConnectionPoints.CreateConnectionPoint(const IID: TGUID;
  1380.   Kind: TConnectionKind; OnConnect: TConnectEvent): TConnectionPoint;
  1381. begin
  1382.   Result := TConnectionPoint.Create(Self, IID, Kind, OnConnect);
  1383. end;
  1384.  
  1385. { TConnectionPoints.IConnectionPointContainer }
  1386.  
  1387. function TConnectionPoints.EnumConnectionPoints(
  1388.   out enumconn: IEnumConnectionPoints): HResult;
  1389. begin
  1390.   try
  1391.     enumconn := TEnumConnectionPoints.Create(Self, 0);
  1392.     Result := S_OK;
  1393.   except
  1394.     Result := E_UNEXPECTED;
  1395.   end;
  1396. end;
  1397.  
  1398. function TConnectionPoints.FindConnectionPoint(const iid: TIID;
  1399.   out cp: IConnectionPoint): HResult;
  1400. var
  1401.   I: Integer;
  1402.   ConnectionPoint: TConnectionPoint;
  1403. begin
  1404.   for I := 0 to FConnectionPoints.Count - 1 do
  1405.   begin
  1406.     ConnectionPoint := FConnectionPoints[I];
  1407.     if IsEqualGUID(ConnectionPoint.FIID, iid) then
  1408.     begin
  1409.       cp := ConnectionPoint;
  1410.       Result := S_OK;
  1411.       Exit;
  1412.     end;
  1413.   end;
  1414.   Result := CONNECT_E_NOCONNECTION;
  1415. end;
  1416.  
  1417. function TConnectionPoints.GetController: IUnknown;
  1418. begin
  1419.   Result := IUnknown(FController);
  1420. end;
  1421.  
  1422. { TReflectorWindow }
  1423.  
  1424.  
  1425. constructor TReflectorWindow.Create(ParentWindow: HWND; Control: TControl);
  1426. begin
  1427.   inherited CreateParented(ParentWindow);
  1428.   FControl := Control;
  1429.   FInSize := True;
  1430.   try
  1431.     FControl.Parent := Self;
  1432.     FControl.SetBounds(0, 0, FControl.Width, FControl.Height);
  1433.   finally
  1434.     FInSize := False;
  1435.   end;
  1436.   SetBounds(Left, Top, FControl.Width, FControl.Height);
  1437. end;
  1438.  
  1439. procedure TReflectorWindow.WMGetDlgCode(var Message: TMessage);
  1440. begin
  1441.   TWinControlAccess(FControl).WndProc(Message);
  1442. end;
  1443.  
  1444. procedure TReflectorWindow.WMSetFocus(var Message: TWMSetFocus);
  1445. begin
  1446.   if FControl is TWinControl then
  1447.     Windows.SetFocus(TWinControl(FControl).Handle) else
  1448.     inherited;
  1449. end;
  1450.  
  1451. procedure TReflectorWindow.WMSize(var Message: TWMSize);
  1452. begin
  1453.   if not FInSize then
  1454.   begin
  1455.     FInSize := True;
  1456.     try
  1457.       FControl.SetBounds(0, 0, Message.Width, Message.Height);
  1458.       SetBounds(Left, Top, FControl.Width, FControl.Height);
  1459.     finally
  1460.       FInSize := False;
  1461.     end;
  1462.   end;
  1463.   inherited;
  1464. end;
  1465.  
  1466. { TOleLinkStub }
  1467.  
  1468. type
  1469.   TOleLinkStub = class(TInterfacedObject, IUnknown, IOleLink)
  1470.   private
  1471.     Controller: IUnknown;
  1472.   public
  1473.     constructor Create(const AController: IUnknown);
  1474.     { IUnknown }
  1475.     function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
  1476.     { IOleLink }
  1477.     function SetUpdateOptions(dwUpdateOpt: Longint): HResult;
  1478.       stdcall;
  1479.     function GetUpdateOptions(out dwUpdateOpt: Longint): HResult; stdcall;
  1480.     function SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
  1481.       stdcall;
  1482.     function GetSourceMoniker(out mk: IMoniker): HResult; stdcall;
  1483.     function SetSourceDisplayName(pszDisplayName: POleStr): HResult;
  1484.       stdcall;
  1485.     function GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
  1486.       stdcall;
  1487.     function BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
  1488.       stdcall;
  1489.     function BindIfRunning: HResult; stdcall;
  1490.     function GetBoundSource(out unk: IUnknown): HResult; stdcall;
  1491.     function UnbindSource: HResult; stdcall;
  1492.     function Update(const bc: IBindCtx): HResult; stdcall;
  1493.   end;
  1494.  
  1495. constructor TOleLinkStub.Create(const AController: IUnknown);
  1496. begin
  1497.   inherited Create;
  1498.   Controller := AController;
  1499. end;
  1500.  
  1501. { TOleLinkStub.IUnknown }
  1502.  
  1503. function TOleLinkStub.QueryInterface(const IID: TGUID; out Obj): HResult;
  1504. begin
  1505.   Result := Controller.QueryInterface(IID, Obj);
  1506. end;
  1507.  
  1508. { TOleLinkStub.IOleLink }
  1509.  
  1510. function TOleLinkStub.SetUpdateOptions(dwUpdateOpt: Longint): HResult;
  1511. begin
  1512.   Result := E_NOTIMPL;
  1513. end;
  1514.  
  1515. function TOleLinkStub.GetUpdateOptions(out dwUpdateOpt: Longint): HResult;
  1516. begin
  1517.   Result := E_NOTIMPL;
  1518. end;
  1519.  
  1520. function TOleLinkStub.SetSourceMoniker(const mk: IMoniker; const clsid: TCLSID): HResult;
  1521. begin
  1522.   Result := E_NOTIMPL;
  1523. end;
  1524.  
  1525. function TOleLinkStub.GetSourceMoniker(out mk: IMoniker): HResult;
  1526. begin
  1527.   Result := E_NOTIMPL;
  1528. end;
  1529.  
  1530. function TOleLinkStub.SetSourceDisplayName(pszDisplayName: POleStr): HResult;
  1531. begin
  1532.   Result := E_NOTIMPL;
  1533. end;
  1534.  
  1535. function TOleLinkStub.GetSourceDisplayName(out pszDisplayName: POleStr): HResult;
  1536. begin
  1537.   pszDisplayName := nil;
  1538.   Result := E_FAIL;
  1539. end;
  1540.  
  1541. function TOleLinkStub.BindToSource(bindflags: Longint; const bc: IBindCtx): HResult;
  1542. begin
  1543.   Result := E_NOTIMPL;
  1544. end;
  1545.  
  1546. function TOleLinkStub.BindIfRunning: HResult;
  1547. begin
  1548.   Result := S_OK;
  1549. end;
  1550.  
  1551. function TOleLinkStub.GetBoundSource(out unk: IUnknown): HResult;
  1552. begin
  1553.   Result := E_NOTIMPL;
  1554. end;
  1555.  
  1556. function TOleLinkStub.UnbindSource: HResult;
  1557. begin
  1558.   Result := E_NOTIMPL;
  1559. end;
  1560.  
  1561. function TOleLinkStub.Update(const bc: IBindCtx): HResult;
  1562. begin
  1563.   Result := E_NOTIMPL;
  1564. end;
  1565.  
  1566. { TActiveXControl }
  1567.  
  1568. procedure TActiveXControl.Initialize;
  1569. begin
  1570.   inherited Initialize;
  1571.   FConnectionPoints := TConnectionPoints.Create(Self);
  1572.   FControlFactory := Factory as TActiveXControlFactory;
  1573.   if FControlFactory.EventTypeInfo <> nil then
  1574.     FConnectionPoints.CreateConnectionPoint(FControlFactory.EventIID,
  1575.       ckSingle, EventConnect);
  1576.   FPropertySinks := FConnectionPoints.CreateConnectionPoint(IPropertyNotifySink,
  1577.     ckMulti, nil);
  1578.   FControl := FControlFactory.WinControlClass.CreateParented(ParkingWindow);
  1579.   if csReflector in FControl.ControlStyle then
  1580.     FWinControl := TReflectorWindow.Create(ParkingWindow, FControl) else
  1581.     FWinControl := FControl;
  1582.   FControlWndProc := FControl.WindowProc;
  1583.   FControl.WindowProc := WndProc;
  1584.   InitializeControl;
  1585. end;
  1586.  
  1587. destructor TActiveXControl.Destroy;
  1588. begin
  1589.   if Assigned(FControlWndProc) then FControl.WindowProc := FControlWndProc;
  1590.   FControl.Free;
  1591.   if FWinControl <> FControl then FWinControl.Free;
  1592.   FConnectionPoints.Free;
  1593.   inherited Destroy;
  1594. end;
  1595.  
  1596. function TActiveXControl.CreateAdviseHolder: HResult;
  1597. begin
  1598.   if FOleAdviseHolder = nil then
  1599.     Result := CreateOleAdviseHolder(FOleAdviseHolder) else
  1600.     Result := S_OK;
  1601. end;
  1602.  
  1603. procedure TActiveXControl.DefinePropertyPages(
  1604.   DefinePropertyPage: TDefinePropertyPage);
  1605. begin
  1606. end;
  1607.  
  1608. function TActiveXControl.GetPropertyString(DispID: Integer;
  1609.   var S: string): Boolean;
  1610. begin
  1611.   Result := False;
  1612. end;
  1613.  
  1614. function TActiveXControl.GetPropertyStrings(DispID: Integer;
  1615.   Strings: TStrings): Boolean;
  1616. begin
  1617.   Result := False;
  1618. end;
  1619.  
  1620. procedure TActiveXControl.GetPropFromBag(const PropName: WideString;
  1621.   DispatchID: Integer; PropBag: IPropertyBag; ErrorLog: IErrorLog);
  1622. var
  1623.   PropValue: OleVariant;
  1624. begin
  1625.   //  Note: raise an EAbort exception here to stop properties from loading
  1626.   if PropBag.Read(PWideChar(PropName), PropValue, ErrorLog) = S_OK then
  1627.     SetDispatchPropValue(Self as IDispatch, DispatchID, PropValue);
  1628. end;
  1629.  
  1630. procedure TActiveXControl.PutPropInBag(const PropName: WideString;
  1631.   DispatchID: Integer; PropBag: IPropertyBag);
  1632. begin
  1633.   PropBag.Write(PWideChar(PropName), GetDispatchPropValue(Self as IDispatch,
  1634.     DispatchID));
  1635. end;
  1636.  
  1637. procedure TActiveXControl.GetPropertyValue(DispID, Cookie: Integer;
  1638.   var Value: OleVariant);
  1639. begin
  1640. end;
  1641.  
  1642. procedure TActiveXControl.InitializeControl;
  1643. begin
  1644. end;
  1645.  
  1646. function TActiveXControl.InPlaceActivate(ActivateUI: Boolean): HResult;
  1647. var
  1648.   InPlaceActivateSent: Boolean;
  1649.   ParentWindow: HWND;
  1650.   PosRect, ClipRect: TRect;
  1651.   FrameInfo: TOleInPlaceFrameInfo;
  1652. begin
  1653.   Result := S_OK;
  1654.   FWinControl.Visible := True;
  1655.   InPlaceActivateSent := False;
  1656.   if not FInPlaceActive then
  1657.     try
  1658.       if FOleClientSite = nil then OleError(E_FAIL);
  1659.       OleCheck(FOleClientSite.QueryInterface(IOleInPlaceSite, FOleInPlaceSite));
  1660.       if FOleInPlaceSite.CanInPlaceActivate <> S_OK then OleError(E_FAIL);
  1661.       OleCheck(FOleInPlaceSite.OnInPlaceActivate);
  1662.       InPlaceActivateSent := True;
  1663.       OleCheck(FOleInPlaceSite.GetWindow(ParentWindow));
  1664.       FrameInfo.cb := SizeOf(FrameInfo);
  1665.       OleCheck(FOleInPlaceSite.GetWindowContext(FOleInPlaceFrame,
  1666.         FOleInPlaceUIWindow, PosRect, ClipRect, FrameInfo));
  1667.       if FOleInPlaceFrame = nil then OleError(E_FAIL);
  1668.       with PosRect do
  1669.         FWinControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
  1670.       FWinControl.ParentWindow := ParentWindow;
  1671.       FWinControl.Visible := True;
  1672.       FInPlaceActive := True;
  1673.       FOleClientSite.ShowObject;
  1674.     except
  1675.       FInPlaceActive := False;
  1676.       FOleInPlaceUIWindow := nil;
  1677.       FOleInPlaceFrame := nil;
  1678.       if InPlaceActivateSent then FOleInPlaceSite.OnInPlaceDeactivate;
  1679.       FOleInPlaceSite := nil;
  1680.       Result := HandleException;
  1681.       Exit;
  1682.     end;
  1683.   if ActivateUI and not FUIActive then
  1684.   begin
  1685.     FUIActive := True;
  1686.     FOleInPlaceSite.OnUIActivate;
  1687.     SetFocus(FWinControl.Handle);
  1688.     FOleInPlaceFrame.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
  1689.     if FOleInPlaceUIWindow <> nil then
  1690.       FOleInPlaceUIWindow.SetActiveObject(Self as IOleInPlaceActiveObject, nil);
  1691.     FOleInPlaceFrame.SetBorderSpace(nil);
  1692.     if FOleInPlaceUIWindow <> nil then
  1693.       FOleInPlaceUIWindow.SetBorderSpace(nil);
  1694.   end;
  1695. end;
  1696.  
  1697. procedure TActiveXControl.LoadFromStream(const Stream: IStream);
  1698. var
  1699.   OleStream: TOleStream;
  1700. begin
  1701.   OleStream := TOleStream.Create(Stream);
  1702.   try
  1703.     OleStream.ReadComponent(FControl);
  1704.   finally
  1705.     OleStream.Free;
  1706.   end;
  1707. end;
  1708.  
  1709. function TActiveXControl.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
  1710. begin
  1711.   if IsEqualGuid(IID, ISimpleFrameSite) and
  1712.     ((FControlFactory.MiscStatus and OLEMISC_SIMPLEFRAME) = 0) then
  1713.     Result := E_NOINTERFACE
  1714.   else
  1715.   begin
  1716.     Result := inherited ObjQueryInterface(IID, Obj);
  1717.     if Result <> 0 then
  1718.       if IsEqualGuid(IID, IOleLink) then
  1719.       begin
  1720.         // Work around for an MS Access 97 bug that requires IOleLink
  1721.         // to be stubbed.
  1722.         Pointer(Obj) := nil;
  1723.         IOleLink(Obj) := TOleLinkStub.Create(Self);
  1724.       end;
  1725.   end;
  1726. end;
  1727.  
  1728. procedure TActiveXControl.PerformVerb(Verb: Integer);
  1729. begin
  1730. end;
  1731.  
  1732. function TActiveXControl.GetPropertyID(const PropertyName: WideString): Integer;
  1733. var
  1734.   PName: PWideChar;
  1735. begin
  1736.   PName := PWideChar(PropertyName);
  1737.   if PropertyName = '' then
  1738.     Result := DISPID_UNKNOWN else
  1739.     OleCheck(GetIDsOfNames(GUID_NULL, @PName, 1, GetThreadLocale,
  1740.       @Result));
  1741. end;
  1742.  
  1743. procedure TActiveXControl.PropChanged(const PropertyName: WideString);
  1744. var
  1745.   PropID: Integer;
  1746. begin
  1747.   PropID := GetPropertyID(PropertyName);
  1748.   PropChanged(PropID);
  1749. end;
  1750.  
  1751. procedure TActiveXControl.PropChanged(DispID: TDispID);
  1752. var
  1753.   Enum: IEnumConnections;
  1754.   ConnectData: TConnectData;
  1755.   Fetched: Longint;
  1756. begin
  1757.   OleCheck(FPropertySinks.EnumConnections(Enum));
  1758.   while Enum.Next(1, ConnectData, @Fetched) = S_OK do
  1759.   begin
  1760.     (ConnectData.pUnk as IPropertyNotifySink).OnChanged(DispID);
  1761.     ConnectData.pUnk := nil;
  1762.   end;
  1763. end;
  1764.  
  1765. function TActiveXControl.PropRequestEdit(const PropertyName: WideString): Boolean;
  1766. var
  1767.   PropID: Integer;
  1768. begin
  1769.   PropID := GetPropertyID(PropertyName);
  1770.   Result := PropRequestEdit(PropID);
  1771. end;
  1772.  
  1773. function TActiveXControl.PropRequestEdit(DispID: TDispID): Boolean;
  1774. var
  1775.   Enum: IEnumConnections;
  1776.   ConnectData: TConnectData;
  1777.   Fetched: Longint;
  1778. begin
  1779.   Result := True;
  1780.   OleCheck(FPropertySinks.EnumConnections(Enum));
  1781.   while Enum.Next(1, ConnectData, @Fetched) = S_OK do
  1782.   begin
  1783.     Result := (ConnectData.pUnk as IPropertyNotifySink).OnRequestEdit(DispID) = S_OK;
  1784.     ConnectData.pUnk := nil;
  1785.     if not Result then Exit;
  1786.   end;
  1787. end;
  1788.  
  1789. procedure TActiveXControl.RecreateWnd;
  1790. var
  1791.   WasUIActive: Boolean;
  1792.   PrevWnd: HWND;
  1793. begin
  1794.   if FWinControl.HandleAllocated then
  1795.   begin
  1796.     WasUIActive := FUIActive;
  1797.     PrevWnd := Windows.GetWindow(FWinControl.Handle, GW_HWNDPREV);
  1798.     InPlaceDeactivate;
  1799.     TWinControlAccess(FWinControl).DestroyHandle;
  1800.     if InPlaceActivate(WasUIActive) = S_OK then
  1801.       SetWindowPos(FWinControl.Handle, PrevWnd, 0, 0, 0, 0,
  1802.         SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
  1803.   end;
  1804. end;
  1805.  
  1806. procedure TActiveXControl.SaveToStream(const Stream: IStream);
  1807. var
  1808.   OleStream: TOleStream;
  1809.   Writer: TWriter;
  1810. begin
  1811.   OleStream := TOleStream.Create(Stream);
  1812.   try
  1813.     Writer := TWriter.Create(OleStream, 4096);
  1814.     try
  1815.       Writer.IgnoreChildren := True;
  1816.       Writer.WriteDescendent(FControl, nil);
  1817.     finally
  1818.       Writer.Free;
  1819.     end;
  1820.   finally
  1821.     OleStream.Free;
  1822.   end;
  1823. end;
  1824.  
  1825. procedure TActiveXControl.ShowPropertyDialog;
  1826. var
  1827.   Unknown: IUnknown;
  1828.   Pages: TCAGUID;
  1829. begin
  1830.   if (FOleControlSite <> nil) and
  1831.     (FOleControlSite.ShowPropertyFrame = S_OK) then Exit;
  1832.   OleCheck(GetPages(Pages));
  1833.   try
  1834.     if Pages.cElems > 0 then
  1835.     begin
  1836.       if FOleInPlaceFrame <> nil then
  1837.         FOleInPlaceFrame.EnableModeless(False);
  1838.       try
  1839.         Unknown := Self;
  1840.         OleCheck(OleCreatePropertyFrame(GetActiveWindow, 16, 16,
  1841.           PWideChar(FAmbientDispatch.DisplayName), {!!!}
  1842.           1, @Unknown, Pages.cElems, Pages.pElems,
  1843.           GetSystemDefaultLCID, 0, nil));
  1844.       finally
  1845.         if FOleInPlaceFrame <> nil then
  1846.           FOleInPlaceFrame.EnableModeless(True);
  1847.       end;
  1848.     end;
  1849.   finally
  1850.     CoFreeMem(pages.pElems);
  1851.   end;
  1852. end;
  1853.  
  1854. procedure TActiveXControl.SetInPlaceSite(const NewInPlaceSite: IOleInPlaceSite);
  1855. begin
  1856.   FOleInPlaceSite := NewInPlaceSite;
  1857. end;
  1858.  
  1859. procedure TActiveXControl.StdClickEvent(Sender: TObject);
  1860. begin
  1861.   if EventSink <> nil then IStdEvents(EventSink).Click;
  1862. end;
  1863.  
  1864. procedure TActiveXControl.StdDblClickEvent(Sender: TObject);
  1865. begin
  1866.   if EventSink <> nil then IStdEvents(EventSink).DblClick;
  1867. end;
  1868.  
  1869. procedure TActiveXControl.StdKeyDownEvent(Sender: TObject; var Key: Word;
  1870.   Shift: TShiftState);
  1871. begin
  1872.   if EventSink <> nil then
  1873.     IStdEvents(EventSink).KeyDown(Smallint(Key), GetEventShift(Shift));
  1874. end;
  1875.  
  1876. procedure TActiveXControl.StdKeyPressEvent(Sender: TObject; var Key: Char);
  1877. var
  1878.   KeyAscii: Smallint;
  1879. begin
  1880.   if EventSink <> nil then
  1881.   begin
  1882.     KeyAscii := Ord(Key);
  1883.     IStdEvents(EventSink).KeyPress(KeyAscii);
  1884.     Key := Chr(KeyAscii);
  1885.   end;
  1886. end;
  1887.  
  1888. procedure TActiveXControl.StdKeyUpEvent(Sender: TObject; var Key: Word;
  1889.   Shift: TShiftState);
  1890. begin
  1891.   if EventSink <> nil then
  1892.     IStdEvents(EventSink).KeyUp(Smallint(Key), GetEventShift(Shift));
  1893. end;
  1894.  
  1895. procedure TActiveXControl.StdMouseDownEvent(Sender: TObject;
  1896.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1897. begin
  1898.   if EventSink <> nil then
  1899.     IStdEvents(EventSink).MouseDown(GetEventButton(Button),
  1900.       GetEventShift(Shift), X, Y);
  1901. end;
  1902.  
  1903. procedure TActiveXControl.StdMouseMoveEvent(Sender: TObject;
  1904.   Shift: TShiftState; X, Y: Integer);
  1905. begin
  1906.   if EventSink <> nil then
  1907.     IStdEvents(EventSink).MouseMove((Byte(Shift) shr 3) and 7,
  1908.       GetEventShift(Shift), X, Y);
  1909. end;
  1910.  
  1911. procedure TActiveXControl.StdMouseUpEvent(Sender: TObject;
  1912.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1913. begin
  1914.   if EventSink <> nil then
  1915.     IStdEvents(EventSink).MouseUp(GetEventButton(Button),
  1916.       GetEventShift(Shift), X, Y);
  1917. end;
  1918.  
  1919. procedure TActiveXControl.ViewChanged;
  1920. begin
  1921.   if FAdviseSink <> nil then
  1922.   begin
  1923.     FAdviseSink.OnViewChange(DVASPECT_CONTENT, -1);
  1924.     if FAdviseFlags and ADVF_ONLYONCE <> 0 then FAdviseSink := nil;
  1925.   end;
  1926. end;
  1927.  
  1928. procedure TActiveXControl.WndProc(var Message: TMessage);
  1929. var
  1930.   Handle: HWnd;
  1931.   FilterMessage: Boolean;
  1932.   Cookie: Longint;
  1933.  
  1934.   procedure ControlWndProc;
  1935.   begin
  1936.     with Message do
  1937.       if (Msg >= OCM_BASE) and (Msg < OCM_BASE + WM_USER) then
  1938.         Msg := Msg + (CN_BASE - OCM_BASE);
  1939.     FControlWndProc(Message);
  1940.     with Message do
  1941.       if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
  1942.         Msg := Msg - (CN_BASE - OCM_BASE);
  1943.   end;
  1944.  
  1945. begin
  1946.   with Message do
  1947.   begin
  1948.     Handle := TWinControlAccess(FControl).WindowHandle;
  1949.     FilterMessage := ((Msg < CM_BASE) or (Msg >= $C000)) and
  1950.       (FSimpleFrameSite <> nil) and FInPlaceActive;
  1951.     if FilterMessage then
  1952.       if FSimpleFrameSite.PreMessageFilter(Handle, Msg, WParam, LParam,
  1953.         Integer(Result), Cookie) = S_FALSE then Exit;
  1954.     case Msg of
  1955.       WM_SETFOCUS, WM_KILLFOCUS:
  1956.         begin
  1957.           ControlWndProc;
  1958.           if FOleControlSite <> nil then
  1959.             FOleControlSite.OnFocus(Msg = WM_SETFOCUS);
  1960.         end;
  1961.       CM_VISIBLECHANGED:
  1962.         begin
  1963.           if FControl <> FWinControl then FWinControl.Visible := FControl.Visible;
  1964.           if not FWinControl.Visible then UIDeactivate;
  1965.           ControlWndProc;
  1966.         end;
  1967.       CM_RECREATEWND:
  1968.         begin
  1969.           if FInPlaceActive and (FControl = FWinControl) then
  1970.             RecreateWnd
  1971.           else
  1972.           begin
  1973.             ControlWndProc;
  1974.             ViewChanged;
  1975.           end;
  1976.         end;
  1977.       CM_INVALIDATE,
  1978.       WM_SETTEXT:
  1979.         begin
  1980.           ControlWndProc;
  1981.           if not FInPlaceActive then ViewChanged;
  1982.         end;
  1983.       WM_NCHITTEST:
  1984.         begin
  1985.           ControlWndProc;
  1986.           if Message.Result = HTTRANSPARENT then Message.Result := HTCLIENT;
  1987.         end;
  1988.       WM_MOUSEACTIVATE:
  1989.         begin
  1990.           ControlWndProc;
  1991.           if not FUIActive and ((Message.Result = MA_ACTIVATE) or
  1992.             (Message.Result = MA_ACTIVATEANDEAT)) and (FAmbientDispatch <> nil)
  1993.             and FAmbientDispatch.UserMode then
  1994.             InPlaceActivate(True);
  1995.         end;
  1996.     else
  1997.       ControlWndProc;
  1998.     end;
  1999.     if FilterMessage then
  2000.       FSimpleFrameSite.PostMessageFilter(Handle, Msg, WParam, LParam,
  2001.         Integer(Result), Cookie);
  2002.   end;
  2003. end;
  2004.  
  2005. { TActiveXControl standard properties }
  2006.  
  2007. function TActiveXControl.Get_BackColor: Integer;
  2008. begin
  2009.   Result := TWinControlAccess(FControl).Color;
  2010. end;
  2011.  
  2012. function TActiveXControl.Get_Caption: WideString;
  2013. begin
  2014.   Result := TWinControlAccess(FControl).Caption;
  2015. end;
  2016.  
  2017. function TActiveXControl.Get_Enabled: WordBool;
  2018. begin
  2019.   Result := FControl.Enabled;
  2020. end;
  2021.  
  2022. function TActiveXControl.Get_Font: Font;
  2023. begin
  2024.   GetOleFont(TWinControlAccess(FControl).Font, Result);
  2025. end;
  2026.  
  2027. function TActiveXControl.Get_ForeColor: Integer;
  2028. begin
  2029.   Result := TWinControlAccess(FControl).Font.Color;
  2030. end;
  2031.  
  2032. function TActiveXControl.Get_HWnd: Integer;
  2033. begin
  2034.   Result := FControl.Handle;
  2035. end;
  2036.  
  2037. function TActiveXControl.Get_TabStop: WordBool;
  2038. begin
  2039.   Result := FControl.TabStop;
  2040. end;
  2041.  
  2042. function TActiveXControl.Get_Text: WideString;
  2043. begin
  2044.   Result := TWinControlAccess(FControl).Text;
  2045. end;
  2046.  
  2047. procedure TActiveXControl.Set_BackColor(Value: Integer);
  2048. begin
  2049.   TWinControlAccess(FControl).Color := Value;
  2050. end;
  2051.  
  2052. procedure TActiveXControl.Set_Caption(const Value: WideString);
  2053. begin
  2054.   TWinControlAccess(FControl).Caption := Value;
  2055. end;
  2056.  
  2057. procedure TActiveXControl.Set_Enabled(Value: WordBool);
  2058. begin
  2059.   FControl.Enabled := Value;
  2060. end;
  2061.  
  2062. procedure TActiveXControl.Set_Font(const Value: Font);
  2063. begin
  2064.   SetOleFont(TWinControlAccess(FControl).Font, Value);
  2065. end;
  2066.  
  2067. procedure TActiveXControl.Set_ForeColor(Value: Integer);
  2068. begin
  2069.   TWinControlAccess(FControl).Font.Color := Value;
  2070. end;
  2071.  
  2072. procedure TActiveXControl.Set_TabStop(Value: WordBool);
  2073. begin
  2074.   FControl.TabStop := Value;
  2075. end;
  2076.  
  2077. procedure TActiveXControl.Set_Text(const Value: WideString);
  2078. begin
  2079.   TWinControlAccess(FControl).Text := Value;
  2080. end;
  2081.  
  2082. { TActiveXControl.IPersist }
  2083.  
  2084. function TActiveXControl.GetClassID(out classID: TCLSID): HResult;
  2085. begin
  2086.   classID := Factory.ClassID;
  2087.   Result := S_OK;
  2088. end;
  2089.  
  2090. { TActiveXControl.IPersistPropertyBag }
  2091.  
  2092. function TActiveXControl.PersistPropBagInitNew: HResult;
  2093. begin
  2094.   Result := S_OK;
  2095. end;
  2096.  
  2097. function TActiveXControl.PersistPropBagLoad(const pPropBag: IPropertyBag;
  2098.   const pErrorLog: IErrorLog): HResult;
  2099. var
  2100.   PropList: TStringList;
  2101.   i: Integer;
  2102. begin
  2103.   try
  2104.     if pPropBag = nil then
  2105.     begin
  2106.       Result := E_POINTER;
  2107.       Exit;
  2108.     end;
  2109.     PropList := TStringList.Create;
  2110.     try
  2111.       EnumDispatchProperties(Self as IDispatch, GUID_NULL, VT_EMPTY, PropList);
  2112.       for i := 0 to PropList.Count - 1 do
  2113.         try
  2114.           GetPropFromBag(PropList[i], Integer(PropList.Objects[i]),
  2115.             pPropBag, pErrorLog);
  2116.         except
  2117.           // Supress all exceptions except EAbort
  2118.           if ExceptObject is EAbort then
  2119.           begin
  2120.             Result := E_FAIL;
  2121.             Exit;
  2122.           end;
  2123.         end;
  2124.     finally
  2125.       PropList.Free;
  2126.     end;
  2127.   Result := S_OK;
  2128.   except
  2129.     Result := HandleException;
  2130.   end;
  2131. end;
  2132.  
  2133. function TActiveXControl.PersistPropBagSave(const pPropBag: IPropertyBag;
  2134.   fClearDirty: BOOL; fSaveAllProperties: BOOL): HResult;
  2135. var
  2136.   PropList: TStringList;
  2137.   i: Integer;
  2138. begin
  2139.   try
  2140.     if pPropBag = nil then
  2141.     begin
  2142.       Result := E_POINTER;
  2143.       Exit;
  2144.     end;
  2145.     PropList := TStringList.Create;
  2146.     try
  2147.       EnumDispatchProperties(Self as IDispatch, GUID_NULL, VT_EMPTY, PropList);
  2148.       for i := 0 to PropList.Count - 1 do
  2149.         PutPropInBag(PropList[i], Integer(PropList.Objects[i]), pPropBag);
  2150.     finally
  2151.       PropList.Free;
  2152.     end;
  2153.     if fClearDirty then FIsDirty := False;
  2154.     Result := S_OK;
  2155.   except
  2156.     Result := HandleException;
  2157.   end;
  2158. end;
  2159.  
  2160. { TActiveXControl.IPersistStreamInit }
  2161.  
  2162. function TActiveXControl.IsDirty: HResult;
  2163. begin
  2164.   if FIsDirty then Result := S_OK else Result := S_FALSE;
  2165. end;
  2166.  
  2167. function TActiveXControl.PersistStreamLoad(const stm: IStream): HResult;
  2168. begin
  2169.   try
  2170.     LoadFromStream(stm);
  2171.     FIsDirty := False;
  2172.     Result := S_OK;
  2173.   except
  2174.     Result := HandleException;
  2175.   end;
  2176. end;
  2177.  
  2178. function TActiveXControl.PersistStreamSave(const stm: IStream;
  2179.   fClearDirty: BOOL): HResult;
  2180. begin
  2181.   try
  2182.     SaveToStream(stm);
  2183.     if fClearDirty then FIsDirty := False;
  2184.     Result := S_OK;
  2185.   except
  2186.     Result := HandleException;
  2187.   end;
  2188. end;
  2189.  
  2190. function TActiveXControl.GetSizeMax(out cbSize: Largeint): HResult;
  2191. begin
  2192.   Result := E_NOTIMPL;
  2193. end;
  2194.  
  2195. function TActiveXControl.InitNew: HResult;
  2196. begin
  2197.   try
  2198.     FIsDirty := False;
  2199.     Result := S_OK;
  2200.   except
  2201.     Result := HandleException;
  2202.   end;
  2203. end;
  2204.  
  2205. { TActiveXControl.IPersistStorage }
  2206.  
  2207. function TActiveXControl.PersistStorageInitNew(const stg: IStorage): HResult;
  2208. begin
  2209.   Result := InitNew;
  2210. end;
  2211.  
  2212. function TActiveXControl.PersistStorageLoad(const stg: IStorage): HResult;
  2213. var
  2214.   Stream: IStream;
  2215. begin
  2216.   try
  2217.     OleCheck(stg.OpenStream('CONTROLSAVESTREAM'#0, nil, STGM_READ +
  2218.       STGM_SHARE_EXCLUSIVE, 0, Stream));
  2219.     LoadFromStream(Stream);
  2220.     FIsDirty := False;
  2221.     Result := S_OK;
  2222.   except
  2223.     Result := HandleException;
  2224.   end;
  2225. end;
  2226.  
  2227. function TActiveXControl.PersistStorageSave(const stgSave: IStorage;
  2228.   fSameAsLoad: BOOL): HResult;
  2229. var
  2230.   Stream: IStream;
  2231. begin
  2232.   try
  2233.     OleCheck(stgSave.CreateStream('CONTROLSAVESTREAM'#0, STGM_WRITE +
  2234.       STGM_SHARE_EXCLUSIVE + STGM_CREATE, 0, 0, Stream));
  2235.     SaveToStream(Stream);
  2236.     Result := S_OK;
  2237.   except
  2238.     Result := HandleException;
  2239.   end;
  2240. end;
  2241.  
  2242. function TActiveXControl.SaveCompleted(const stgNew: IStorage): HResult;
  2243. begin
  2244.   FIsDirty := False;
  2245.   Result := S_OK;
  2246. end;
  2247.  
  2248. function TActiveXControl.HandsOffStorage: HResult;
  2249. begin
  2250.   Result := S_OK;
  2251. end;
  2252.  
  2253. { TActiveXControl.IObjectSafety }
  2254.  
  2255. function TActiveXControl.GetInterfaceSafetyOptions(const IID: TIID;
  2256.   pdwSupportedOptions, pdwEnabledOptions: PDWORD): HResult;
  2257. var
  2258.   Unk: IUnknown;
  2259. begin
  2260.   if (pdwSupportedOptions = nil) or (pdwEnabledOptions = nil) then
  2261.   begin
  2262.     Result := E_POINTER;
  2263.     Exit;
  2264.   end;
  2265.   Result := QueryInterface(IID, Unk);
  2266.   if Result = S_OK then
  2267.   begin
  2268.     pdwSupportedOptions^ := INTERFACESAFE_FOR_UNTRUSTED_CALLER or
  2269.       INTERFACESAFE_FOR_UNTRUSTED_DATA;
  2270.     pdwEnabledOptions^ := FObjectSafetyFlags and
  2271.       (INTERFACESAFE_FOR_UNTRUSTED_CALLER or INTERFACESAFE_FOR_UNTRUSTED_DATA);
  2272.   end
  2273.   else begin
  2274.     pdwSupportedOptions^ := 0;
  2275.     pdwEnabledOptions^ := 0;
  2276.   end;
  2277. end;
  2278.  
  2279. function TActiveXControl.SetInterfaceSafetyOptions(const IID: TIID;
  2280.   dwOptionSetMask, dwEnabledOptions: DWORD): HResult;
  2281. var
  2282.   Unk: IUnknown;
  2283. begin
  2284.   Result := QueryInterface(IID, Unk);
  2285.   if Result <> S_OK then Exit;
  2286.   FObjectSafetyFlags := dwEnabledOptions and dwOptionSetMask;
  2287. end;
  2288.  
  2289. { TActiveXControl.IOleObject }
  2290.  
  2291. function TActiveXControl.SetClientSite(const ClientSite: IOleClientSite): HResult;
  2292. begin
  2293.   if ClientSite <> nil then
  2294.   begin
  2295.     if FOleClientSite <> nil then
  2296.     begin
  2297.       Result := E_FAIL;
  2298.       Exit;
  2299.     end;
  2300.     FOleClientSite := ClientSite;
  2301.     ClientSite.QueryInterface(IOleControlSite, FOleControlSite);
  2302.     if FControlFactory.MiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
  2303.       ClientSite.QueryInterface(ISimpleFrameSite, FSimpleFrameSite);
  2304.     ClientSite.QueryInterface(IDispatch, FAmbientDispatch);
  2305.     OnAmbientPropertyChange(0);
  2306.   end else
  2307.   begin
  2308.     FAmbientDispatch := nil;
  2309.     FSimpleFrameSite := nil;
  2310.     FOleControlSite := nil;
  2311.     FOleClientSite := nil;
  2312.   end;
  2313.   Result := S_OK;
  2314. end;
  2315.  
  2316. function TActiveXControl.GetClientSite(out clientSite: IOleClientSite): HResult;
  2317. begin
  2318.   ClientSite := FOleClientSite;
  2319.   Result := S_OK;
  2320. end;
  2321.  
  2322. function TActiveXControl.SetHostNames(szContainerApp: POleStr;
  2323.   szContainerObj: POleStr): HResult;
  2324. begin
  2325.   Result := S_OK;
  2326. end;
  2327.  
  2328. function TActiveXControl.Close(dwSaveOption: Longint): HResult;
  2329. begin
  2330.   if (dwSaveOption <> OLECLOSE_NOSAVE) and FIsDirty and
  2331.     (FOleClientSite <> nil) then FOleClientSite.SaveObject;
  2332.   Result := InPlaceDeactivate;
  2333. end;
  2334.  
  2335. function TActiveXControl.SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
  2336. begin
  2337.   Result := E_NOTIMPL;
  2338. end;
  2339.  
  2340. function TActiveXControl.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  2341.   out mk: IMoniker): HResult;
  2342. begin
  2343.   Result := E_NOTIMPL;
  2344. end;
  2345.  
  2346. function TActiveXControl.InitFromData(const dataObject: IDataObject; fCreation: BOOL;
  2347.   dwReserved: Longint): HResult;
  2348. begin
  2349.   Result := E_NOTIMPL;
  2350. end;
  2351.  
  2352. function TActiveXControl.GetClipboardData(dwReserved: Longint;
  2353.   out dataObject: IDataObject): HResult;
  2354. begin
  2355.   Result := E_NOTIMPL;
  2356. end;
  2357.  
  2358. function TActiveXControl.DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
  2359.   lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
  2360. begin
  2361.   try
  2362.     case iVerb of
  2363.       OLEIVERB_SHOW,
  2364.       OLEIVERB_UIACTIVATE:
  2365.         Result := InPlaceActivate(True);
  2366.       OLEIVERB_INPLACEACTIVATE:
  2367.         Result := InPlaceActivate(False);
  2368.       OLEIVERB_HIDE:
  2369.         begin
  2370.           FWinControl.Visible := False;
  2371.           Result := S_OK;
  2372.         end;
  2373.       OLEIVERB_PRIMARY,
  2374.       OLEIVERB_PROPERTIES:
  2375.         begin
  2376.           ShowPropertyDialog;
  2377.           Result := S_OK;
  2378.         end;
  2379.     else
  2380.       if FControlFactory.FVerbs.IndexOfObject(TObject(iVerb)) >= 0 then
  2381.       begin
  2382.         PerformVerb(iVerb);
  2383.         Result := S_OK;
  2384.       end else
  2385.         Result := OLEOBJ_S_INVALIDVERB;
  2386.     end;
  2387.   except
  2388.     Result := HandleException;
  2389.   end;
  2390. end;
  2391.  
  2392. function TActiveXControl.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult;
  2393. begin
  2394.   Result := OleRegEnumVerbs(Factory.ClassID, enumOleVerb);
  2395. end;
  2396.  
  2397. function TActiveXControl.Update: HResult;
  2398. begin
  2399.   Result := S_OK;
  2400. end;
  2401.  
  2402. function TActiveXControl.IsUpToDate: HResult;
  2403. begin
  2404.   Result := S_OK;
  2405. end;
  2406.  
  2407. function TActiveXControl.GetUserClassID(out clsid: TCLSID): HResult;
  2408. begin
  2409.   clsid := Factory.ClassID;
  2410.   Result := S_OK;
  2411. end;
  2412.  
  2413. function TActiveXControl.GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
  2414. begin
  2415.   Result := OleRegGetUserType(Factory.ClassID, dwFormOfType, pszUserType);
  2416. end;
  2417.  
  2418. function TActiveXControl.SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
  2419. var
  2420.   W, H: Integer;
  2421. begin
  2422.   try
  2423.     if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
  2424.     W := MulDiv(Size.X, Screen.PixelsPerInch, 2540);
  2425.     H := MulDiv(Size.Y, Screen.PixelsPerInch, 2540);
  2426.     with FWinControl do SetBounds(Left, Top, W, H);
  2427.     Result := S_OK;
  2428.   except
  2429.     Result := HandleException;
  2430.   end;
  2431. end;
  2432.  
  2433. function TActiveXControl.GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
  2434. begin
  2435.   if dwDrawAspect <> DVASPECT_CONTENT then
  2436.   begin
  2437.     Result := DV_E_DVASPECT;
  2438.     Exit;
  2439.   end;
  2440.   Size.X := MulDiv(FWinControl.Width, 2540, Screen.PixelsPerInch);
  2441.   Size.Y := MulDiv(FWinControl.Height, 2540, Screen.PixelsPerInch);
  2442.   Result := S_OK;
  2443. end;
  2444.  
  2445. function TActiveXControl.Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  2446. begin
  2447.   Result := CreateAdviseHolder;
  2448.   if Result = S_OK then
  2449.     Result := FOleAdviseHolder.Advise(advSink, dwConnection);
  2450. end;
  2451.  
  2452. function TActiveXControl.Unadvise(dwConnection: Longint): HResult;
  2453. begin
  2454.   Result := CreateAdviseHolder;
  2455.   if Result = S_OK then
  2456.     Result := FOleAdviseHolder.Unadvise(dwConnection);
  2457. end;
  2458.  
  2459. function TActiveXControl.EnumAdvise(out enumAdvise: IEnumStatData): HResult;
  2460. begin
  2461.   Result := CreateAdviseHolder;
  2462.   if Result = S_OK then
  2463.     Result := FOleAdviseHolder.EnumAdvise(enumAdvise);
  2464. end;
  2465.  
  2466. function TActiveXControl.GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
  2467. begin
  2468.   if dwAspect <> DVASPECT_CONTENT then
  2469.   begin
  2470.     Result := DV_E_DVASPECT;
  2471.     Exit;
  2472.   end;
  2473.   dwStatus := FControlFactory.FMiscStatus;
  2474.   Result := S_OK;
  2475. end;
  2476.  
  2477. function TActiveXControl.SetColorScheme(const logpal: TLogPalette): HResult;
  2478. begin
  2479.   Result := E_NOTIMPL;
  2480. end;
  2481.  
  2482. { TActiveXControl.IOleControl }
  2483.  
  2484. function TActiveXControl.GetControlInfo(var ci: TControlInfo): HResult;
  2485. begin
  2486.   with ci do
  2487.   begin
  2488.     cb := SizeOf(ci);
  2489.     hAccel := 0;
  2490.     cAccel := 0;
  2491.     dwFlags := 0;
  2492.   end;
  2493.   Result := S_OK;
  2494. end;
  2495.  
  2496. function TActiveXControl.OnMnemonic(msg: PMsg): HResult;
  2497. begin
  2498.   Result := InPlaceActivate(True);
  2499. end;
  2500.  
  2501. function TActiveXControl.OnAmbientPropertyChange(dispid: TDispID): HResult;
  2502. var
  2503.   Font: TFont;
  2504. begin
  2505.   if (FWinControl <> nil) and (FAmbientDispatch <> nil) then
  2506.   begin
  2507.     try
  2508.       FWinControl.Perform(CM_PARENTCOLORCHANGED, 1, FAmbientDispatch.BackColor);
  2509.     except
  2510.     end;
  2511.     FWinControl.Perform(CM_PARENTCTL3DCHANGED, 1, 1);
  2512.     Font := TFont.Create;
  2513.     try
  2514.       Font.Color := FAmbientDispatch.ForeColor;
  2515.       SetOleFont(Font, FAmbientDispatch.Font);
  2516.       FWinControl.Perform(CM_PARENTFONTCHANGED, 1, Integer(Font));
  2517.     except
  2518.     end;
  2519.     Font.Free;
  2520.   end;
  2521.   Result := S_OK;  //OnAmbientPropChange MUST return S_OK in all cases.
  2522. end;
  2523.  
  2524. function TActiveXControl.FreezeEvents(bFreeze: BOOL): HResult;
  2525. begin
  2526.   FEventsFrozen := bFreeze;
  2527.   Result := S_OK;
  2528. end;
  2529.  
  2530. { TActiveXControl.IOleWindow }
  2531.  
  2532. function TActiveXControl.GetWindow(out wnd: HWnd): HResult;
  2533. begin
  2534.   if FWinControl.HandleAllocated then
  2535.   begin
  2536.     wnd := FWinControl.Handle;
  2537.     Result := S_OK;
  2538.   end else
  2539.     Result := E_FAIL;
  2540. end;
  2541.  
  2542. function TActiveXControl.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  2543. begin
  2544.   Result := E_NOTIMPL;
  2545. end;
  2546.  
  2547. { TActiveXControl.IOleInPlaceObject }
  2548.  
  2549. function TActiveXControl.InPlaceDeactivate: HResult;
  2550. begin
  2551.   if FInPlaceActive then
  2552.   begin
  2553.     UIDeactivate;
  2554.     FInPlaceActive := False;
  2555.     FWinControl.Visible := False;
  2556.     FWinControl.ParentWindow := ParkingWindow;
  2557.     FOleInPlaceUIWindow := nil;
  2558.     FOleInPlaceFrame := nil;
  2559.     FOleInPlaceSite.OnInPlaceDeactivate;
  2560.     FOleInPlaceSite := nil;
  2561.   end;
  2562.   FWinControl.Visible := False;
  2563.   Result := S_OK;
  2564. end;
  2565.  
  2566. function TActiveXControl.UIDeactivate: HResult;
  2567. begin
  2568.   if FUIActive then
  2569.   begin
  2570.     if FOleInPlaceUIWindow <> nil then
  2571.       FOleInPlaceUIWindow.SetActiveObject(nil, nil);
  2572.     FOleInPlaceFrame.SetActiveObject(nil, nil);
  2573.     FOleInPlaceSite.OnUIDeactivate(False);
  2574.     FUIActive := False;
  2575.   end;
  2576.   Result := S_OK;
  2577. end;
  2578.  
  2579. function TActiveXControl.SetObjectRects(const rcPosRect: TRect;
  2580.   const rcClipRect: TRect): HResult;
  2581. var
  2582.   WinRect: TRect;
  2583. begin
  2584.   try
  2585.     IntersectRect(WinRect, rcPosRect, rcClipRect);
  2586.     FWinControl.BoundsRect := WinRect;
  2587.     Result := S_OK;
  2588.   except
  2589.     Result := HandleException;
  2590.   end;
  2591. end;
  2592.  
  2593. function TActiveXControl.ReactivateAndUndo: HResult;
  2594. begin
  2595.   Result := E_NOTIMPL;
  2596. end;
  2597.  
  2598. { TActiveXControl.IOleInPlaceActiveObject }
  2599.  
  2600. function TActiveXControl.TranslateAccelerator(var msg: TMsg): HResult;
  2601. var
  2602.   Control: TWinControl;
  2603.   Form: TCustomForm;
  2604.   HWindow: THandle;
  2605.   Mask: Integer;
  2606. begin
  2607.   with Msg do
  2608.     if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST) then
  2609.     begin
  2610.       Control := FindControl(HWnd);
  2611.       if Control = nil then
  2612.       begin
  2613.         HWindow := HWnd;
  2614.         repeat
  2615.           HWindow := GetParent(HWindow);
  2616.           if HWindow <> 0 then Control := FindControl(HWindow);
  2617.         until (HWindow = 0) or (Control <> nil);
  2618.       end;
  2619.       if Control <> nil then
  2620.       begin
  2621.         Result := S_OK;
  2622.         if (Message = WM_KEYDOWN) and (Control.Perform(CM_CHILDKEY, wParam, Integer(Control)) <> 0) then Exit;
  2623.         Mask := 0;
  2624.         case wParam of
  2625.           VK_TAB:
  2626.             Mask := DLGC_WANTTAB;
  2627.           VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN, VK_PRIOR, VK_NEXT, VK_HOME, VK_END:
  2628.             Mask := DLGC_WANTARROWS;
  2629.           VK_RETURN, VK_EXECUTE, VK_ESCAPE, VK_CANCEL:
  2630.             Mask := DLGC_WANTALLKEYS;
  2631.         end;
  2632.         if (Mask <> 0) and
  2633.           ((Control.Perform(CM_WANTSPECIALKEY, wParam, 0) <> 0) or
  2634.           (Control.Perform(WM_GETDLGCODE, 0, 0) and Mask <> 0)) then
  2635.         begin
  2636.           TranslateMessage(msg);
  2637.           DispatchMessage(msg);
  2638.           Exit;
  2639.         end;
  2640.         if (Message = WM_KEYDOWN) and (Control.Parent <> nil) then
  2641.           Form := GetParentForm(Control)
  2642.         else
  2643.           Form := nil;
  2644.         if (Form <> nil) and (Form.Perform(CM_DIALOGKEY, wParam, lParam) = 1) then
  2645.           Exit;
  2646.       end;
  2647.     end;
  2648.   if FOleControlSite <> nil then
  2649.     Result := FOleControlSite.TranslateAccelerator(@msg, GetKeyModifiers)
  2650.   else
  2651.     Result := S_FALSE;
  2652. end;
  2653.  
  2654. function TActiveXControl.OnFrameWindowActivate(fActivate: BOOL): HResult;
  2655. begin
  2656.   Result := InPlaceActivate(True);
  2657.   if Succeeded(Result) then FWinControl.SetFocus;
  2658. end;
  2659.  
  2660. function TActiveXControl.OnDocWindowActivate(fActivate: BOOL): HResult;
  2661. begin
  2662.   Result := InPlaceActivate(True);
  2663. end;
  2664.  
  2665. function TActiveXControl.ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
  2666.   fFrameWindow: BOOL): HResult;
  2667. begin
  2668.   Result := S_OK;
  2669. end;
  2670.  
  2671. function TActiveXControl.EnableModeless(fEnable: BOOL): HResult;
  2672. begin
  2673.   Result := S_OK;
  2674. end;
  2675.  
  2676. { TActiveXControl.IViewObject }
  2677.  
  2678. function TActiveXControl.Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  2679.   ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
  2680.   prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
  2681.   dwContinue: Longint): HResult;
  2682. var
  2683.   R: TRect;
  2684.   SaveIndex: Integer;
  2685.   WasVisible: Boolean;
  2686. begin
  2687.   try
  2688.     if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
  2689.     WasVisible := FControl.Visible;
  2690.     try
  2691.       FControl.Visible := True;
  2692.       ShowWindow(FWinControl.Handle, 1);
  2693.       R := prcBounds^;
  2694.       LPToDP(hdcDraw, R, 2);
  2695.       SaveIndex := SaveDC(hdcDraw);
  2696.       try
  2697.         SetViewportOrgEx(hdcDraw, 0, 0, nil);
  2698.         SetWindowOrgEx(hdcDraw, 0, 0, nil);
  2699.         SetMapMode(hdcDraw, MM_TEXT);
  2700.         FControl.PaintTo(hdcDraw, R.Left, R.Top);
  2701.       finally
  2702.         RestoreDC(hdcDraw, SaveIndex);
  2703.       end;
  2704.     finally
  2705.       FControl.Visible := WasVisible;
  2706.     end;
  2707.     Result := S_OK;
  2708.   except
  2709.     Result := HandleException;
  2710.   end;
  2711. end;
  2712.  
  2713. function TActiveXControl.GetColorSet(dwDrawAspect: Longint; lindex: Longint;
  2714.   pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
  2715.   out colorSet: PLogPalette): HResult;
  2716. begin
  2717.   Result := E_NOTIMPL;
  2718. end;
  2719.  
  2720. function TActiveXControl.Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  2721.   out dwFreeze: Longint): HResult;
  2722. begin
  2723.   Result := E_NOTIMPL;
  2724. end;
  2725.  
  2726. function TActiveXControl.Unfreeze(dwFreeze: Longint): HResult;
  2727. begin
  2728.   Result := E_NOTIMPL;
  2729. end;
  2730.  
  2731. function TActiveXControl.SetAdvise(aspects: Longint; advf: Longint;
  2732.   const advSink: IAdviseSink): HResult;
  2733. begin
  2734.   if aspects and DVASPECT_CONTENT = 0 then
  2735.   begin
  2736.     Result := DV_E_DVASPECT;
  2737.     Exit;
  2738.   end;
  2739.   FAdviseFlags := advf;
  2740.   FAdviseSink := advSink;
  2741.   if FAdviseFlags and ADVF_PRIMEFIRST <> 0 then ViewChanged;
  2742.   Result := S_OK;
  2743. end;
  2744.  
  2745. function TActiveXControl.GetAdvise(pAspects: PLongint; pAdvf: PLongint;
  2746.   out advSink: IAdviseSink): HResult;
  2747. begin
  2748.   if pAspects <> nil then pAspects^ := DVASPECT_CONTENT;
  2749.   if pAdvf <> nil then pAdvf^ := FAdviseFlags;
  2750.   if @advSink <> nil then advSink := FAdviseSink;
  2751.   Result := S_OK;
  2752. end;
  2753.  
  2754. { TActiveXControl.IViewObject2 }
  2755.  
  2756. function TActiveXControl.ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
  2757.   ptd: PDVTargetDevice; out size: TPoint): HResult;
  2758. begin
  2759.   Result := GetExtent(dwDrawAspect, size);
  2760. end;
  2761.  
  2762. { TActiveXControl.IPerPropertyBrowsing }
  2763.  
  2764. function TActiveXControl.GetDisplayString(dispid: TDispID;
  2765.   out bstr: WideString): HResult;
  2766. var
  2767.   S: string;
  2768. begin
  2769.   Result := E_NOTIMPL;
  2770.   if GetPropertyString( dispid, S ) then
  2771.   begin
  2772.     bstr := S;
  2773.     Result := S_OK;
  2774.   end;
  2775. end;
  2776.  
  2777. function TActiveXControl.MapPropertyToPage(dispid: TDispID;
  2778.   out clsid: TCLSID): HResult;
  2779. begin
  2780.   if @clsid <> nil then clsid := GUID_NULL;
  2781.   Result := E_NOTIMPL; {!!!}
  2782. end;
  2783.  
  2784. function TActiveXControl.GetPredefinedStrings(dispid: TDispID;
  2785.   out caStringsOut: TCAPOleStr; out caCookiesOut: TCALongint): HResult;
  2786. var
  2787.   StringList: POleStrList;
  2788.   CookieList: PLongintList;
  2789.   Strings: TStringList;
  2790.   Count, I: Integer;
  2791. begin
  2792.   StringList := nil;
  2793.   CookieList := nil;
  2794.   Count := 0;
  2795.   if (@CaStringsOut = nil) or (@CaCookiesOut = nil) then
  2796.   begin
  2797.     Result := E_POINTER;
  2798.     Exit;
  2799.   end;
  2800.   caStringsOut.cElems := 0;
  2801.   caStringsOut.pElems := nil;
  2802.   caCookiesOut.cElems := 0;
  2803.   caCookiesOut.pElems := nil;
  2804.  
  2805.   try
  2806.     Strings := TStringList.Create;
  2807.     try
  2808.       if GetPropertyStrings(dispid, Strings) then
  2809.       begin
  2810.         Count := Strings.Count;
  2811.         StringList := CoAllocMem(Count * SizeOf(Pointer));
  2812.         CookieList := CoAllocMem(Count * SizeOf(Longint));
  2813.         for I := 0 to Count - 1 do
  2814.         begin
  2815.           StringList[I] := CoAllocString(Strings[I]);
  2816.           CookieList[I] := Longint(Strings.Objects[I]);
  2817.         end;
  2818.         caStringsOut.cElems := Count;
  2819.         caStringsOut.pElems := StringList;
  2820.         caCookiesOut.cElems := Count;
  2821.         caCookiesOut.pElems := CookieList;
  2822.         Result := S_OK;
  2823.       end else
  2824.         Result := E_NOTIMPL;
  2825.     finally
  2826.       Strings.Free;
  2827.     end;
  2828.   except
  2829.     if StringList <> nil then
  2830.       for I := 0 to Count - 1 do CoFreeMem(StringList[I]);
  2831.     CoFreeMem(CookieList);
  2832.     CoFreeMem(StringList);
  2833.     Result := HandleException;
  2834.   end;
  2835. end;
  2836.  
  2837. function TActiveXControl.GetPredefinedValue(dispid: TDispID;
  2838.   dwCookie: Longint; out varOut: OleVariant): HResult;
  2839. var
  2840.   Temp: OleVariant;
  2841. begin
  2842.   GetPropertyValue(dispid, dwCookie, Temp);
  2843.   varOut := Temp;
  2844.   Result := S_OK;
  2845. end;
  2846.  
  2847. { TActiveXControl.ISpecifyPropertyPages }
  2848.  
  2849. type
  2850.   TPropPages = class
  2851.   private
  2852.     FGUIDList: PGUIDList;
  2853.     FCount: Integer;
  2854.     procedure ProcessPage(const GUID: TGUID);
  2855.   end;
  2856.  
  2857. procedure TPropPages.ProcessPage(const GUID: TGUID);
  2858. begin
  2859.   if FGUIDList <> nil then FGUIDList[FCount] := GUID;
  2860.   Inc(FCount);
  2861. end;
  2862.  
  2863. function TActiveXControl.GetPages(out pages: TCAGUID): HResult;
  2864. var
  2865.   PropPages: TPropPages;
  2866. begin
  2867.   try
  2868.     PropPages := TPropPages.Create;
  2869.     try
  2870.       DefinePropertyPages(PropPages.ProcessPage);
  2871.       PropPages.FGUIDList := CoAllocMem(PropPages.FCount * SizeOf(TGUID));
  2872.       PropPages.FCount := 0;
  2873.       DefinePropertyPages(PropPages.ProcessPage);
  2874.       pages.cElems := PropPages.FCount;
  2875.       pages.pElems := PropPages.FGUIDList;
  2876.       PropPages.FGUIDList := nil;
  2877.     finally
  2878.       if PropPages.FGUIDList <> nil then CoFreeMem(PropPages.FGUIDList);
  2879.       PropPages.Free;
  2880.     end;
  2881.     Result := S_OK;
  2882.   except
  2883.     Result := HandleException;
  2884.   end;
  2885. end;
  2886.  
  2887. { ISimpleFrameSite }
  2888.  
  2889. function TActiveXControl.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  2890.  out res: Integer; out Cookie: Longint): HResult;
  2891. begin
  2892.   if FSimpleFrameSite <> nil then
  2893.     Result := FSimpleFrameSite.PreMessageFilter(wnd, msg, wp, lp, res, Cookie)
  2894.   else
  2895.     Result := S_OK;
  2896. end;
  2897.  
  2898. function TActiveXControl.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  2899.   out res: Integer; Cookie: Longint): HResult;
  2900. begin
  2901.   if FSimpleFrameSite <> nil then
  2902.     Result := FSimpleFrameSite.PostMessageFilter(wnd, msg, wp, lp, res, Cookie)
  2903.   else
  2904.     Result := S_OK;
  2905. end;
  2906.  
  2907. { IQuickActivate }
  2908.  
  2909. function TActiveXControl.QuickActivate(var qaCont: TQaContainer; var qaCtrl: TQaControl): HResult; stdcall;
  2910. var
  2911.   Connections: IConnectionPointContainer;
  2912.   EventConnection: IConnectionPoint;
  2913.   PropConnection: IConnectionPoint;
  2914. begin
  2915.    // Verify that caller allocated enough space
  2916.   if qaCtrl.cbSize < SizeOf(TQaControl) then
  2917.   begin
  2918.     Result := E_UNEXPECTED;
  2919.     Exit;
  2920.   end;
  2921.   // Initialize TQaControl structure
  2922.   FillChar(qaCtrl, SizeOf(TQaControl), 0);
  2923.   qaCtrl.cbSize := SizeOf(TQaControl);
  2924.   // Set ClientSite
  2925.   SetClientSite(qaCont.pClientSite);
  2926.   // Set Advise Sink
  2927.   if qaCont.pAdviseSink <> nil then
  2928.     SetAdvise(DVASPECT_CONTENT, 0, qaCont.pAdviseSink);
  2929.   // Grab ConnectionPointContainer
  2930.   Connections := Self as IConnectionPointContainer;
  2931.   // Hook up Property Notify Sink
  2932.   if qaCont.pPropertyNotifySink <> nil then
  2933.   begin
  2934.     if Connections.FindConnectionPoint(IPropertyNotifySink, EventConnection) = S_OK then
  2935.       EventConnection.Advise(qaCont.pPropertyNotifySink, qaCtrl.dwPropNotifyCookie);
  2936.   end;
  2937.   // Hook up default outgoing interface
  2938.   if qaCont.pUnkEventSink <> nil then
  2939.   begin
  2940.     if Connections.FindConnectionPoint(FControlFactory.EventIID, PropConnection) = S_OK then
  2941.       PropConnection.Advise(qaCont.pUnkEventSink, qaCtrl.dwEventCookie);
  2942.   end;
  2943.   // Give information to Container
  2944.   GetMiscStatus(DVASPECT_CONTENT, qaCtrl.dwMiscStatus);
  2945.   // Return SUCCESS
  2946.   Result := S_OK;
  2947. end;
  2948.  
  2949. function TActiveXControl.SetContentExtent(const sizel: TPoint): HResult; stdcall;
  2950. begin
  2951.   Result := SetExtent(DVASPECT_CONTENT, sizel);
  2952. end;
  2953.  
  2954. function TActiveXControl.GetContentExtent(out sizel: TPoint): HResult; stdcall;
  2955. begin
  2956.   Result := GetExtent(DVASPECT_CONTENT, sizel);
  2957. end;
  2958.  
  2959.  
  2960. { IDataObject }
  2961.  
  2962. function TActiveXControl.GetData(const formatetcIn: TFormatEtc;
  2963.   out medium: TStgMedium): HResult; stdcall;
  2964. var
  2965.   sizeMetric: TPoint;
  2966.   dc: HDC;
  2967.   hMF: HMetafile;
  2968.   hMem: THandle;
  2969.   pMFP: PMetafilePict;
  2970.   SaveVisible: Boolean;
  2971.   BM: TBitmap;
  2972. begin
  2973.   // Handle only MetaFile
  2974.   if (formatetcin.tymed and TYMED_MFPICT) = 0 then
  2975.   begin
  2976.     Result := DV_E_FORMATETC;
  2977.     Exit;
  2978.   end;
  2979.   // Retrieve Extent
  2980.   GetExtent(DVASPECT_CONTENT, sizeMetric);
  2981.   // Create Metafile DC and set it up
  2982.   dc := CreateMetafile(nil);
  2983.   SetWindowOrgEx(dc, 0, 0, nil);
  2984.   SetWindowExtEx(dc, sizemetric.X, sizemetric.Y, nil);
  2985.   // Have Control paint to DC and get metafile handle
  2986.   SaveVisible := FControl.Visible;
  2987.   try
  2988.     FControl.Visible := True;
  2989.     BM := TBitmap.Create;
  2990.     try
  2991.       BM.Width := FControl.Width;
  2992.       BM.Height := FControl.Height;
  2993.       FControl.PaintTo(BM.Canvas.Handle, 0, 0);
  2994.       StretchBlt(dc, 0, 0, sizeMetric.X, sizeMetric.Y,
  2995.         BM.Canvas.Handle, 0, 0, BM.Width, BM.Height, SRCCOPY);
  2996.     finally
  2997.       BM.Free;
  2998.     end;
  2999.   finally
  3000.     FControl.Visible := SaveVisible;
  3001.   end;
  3002.   hMF := CloseMetaFile(dc);
  3003.   if hMF = 0 then
  3004.   begin
  3005.     Result := E_UNEXPECTED;
  3006.     Exit;
  3007.   end;
  3008.  
  3009.   // Get memory handle
  3010.   hMEM := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE, sizeof(METAFILEPICT));
  3011.   if hMEM = 0 then
  3012.   begin
  3013.     DeleteMetafile(hMF);
  3014.     Result := STG_E_MEDIUMFULL;
  3015.     Exit;
  3016.   end;
  3017.   pMFP := PMetaFilePict(GlobalLock(hMEM));
  3018.   pMFP^.hMF  := hMF;
  3019.   pMFP^.mm   := MM_ANISOTROPIC;
  3020.   pMFP^.xExt := sizeMetric.X;
  3021.   pMFP^.yExt := sizeMetric.Y;
  3022.   GlobalUnlock(hMEM);
  3023.  
  3024.   medium.tymed := TYMED_MFPICT;
  3025.   medium.hGlobal := hMEM;
  3026.   medium.UnkForRelease := nil;
  3027.  
  3028.   Result := S_OK;
  3029. end;
  3030.  
  3031. function TActiveXControl.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium):
  3032.   HResult; stdcall;
  3033. begin
  3034.   Result := E_NOTIMPL;
  3035. end;
  3036.  
  3037. function TActiveXControl.QueryGetData(const formatetc: TFormatEtc): HResult;
  3038.   stdcall;
  3039. begin
  3040.   Result := E_NOTIMPL;
  3041. end;
  3042.  
  3043. function TActiveXControl.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  3044.   out formatetcOut: TFormatEtc): HResult; stdcall;
  3045. begin
  3046.   Result := E_NOTIMPL;
  3047. end;
  3048.  
  3049. function TActiveXControl.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  3050.   fRelease: BOOL): HResult; stdcall;
  3051. begin
  3052.   Result := E_NOTIMPL;
  3053. end;
  3054.  
  3055. function TActiveXControl.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
  3056.   IEnumFormatEtc): HResult; stdcall;
  3057. begin
  3058.   Result := E_NOTIMPL;
  3059. end;
  3060.  
  3061. function TActiveXControl.DAdvise(const formatetc: TFormatEtc; advf: Longint;
  3062.   const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
  3063. begin
  3064.   Result := S_OK;
  3065.   if FDataAdviseHolder = nil then
  3066.     Result := CreateDataAdviseHolder(FDataAdviseHolder);
  3067.   if Result = S_OK then
  3068.     Result := FDataAdviseHolder.Advise(Self, formatetc, advf, advSink, dwConnection);
  3069. end;
  3070.  
  3071. function TActiveXControl.DUnadvise(dwConnection: Longint): HResult; stdcall;
  3072. begin
  3073.   if FDataAdviseHolder = nil then
  3074.     Result := OLE_E_NOCONNECTION
  3075.   else
  3076.     Result := FDataAdviseHolder.Unadvise(dwConnection);
  3077. end;
  3078.  
  3079. function TActiveXControl.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
  3080.   stdcall;
  3081. begin
  3082.   if FDataAdviseHolder = nil then
  3083.     Result := E_FAIL
  3084.   else
  3085.     Result := FDataAdviseHolder.EnumAdvise(enumAdvise);
  3086. end;
  3087.  
  3088.  
  3089. { TActiveXControlFactory }
  3090.  
  3091. constructor TActiveXControlFactory.Create(ComServer: TComServerObject;
  3092.   ActiveXControlClass: TActiveXControlClass;
  3093.   WinControlClass: TWinControlClass; const ClassID: TGUID;
  3094.   ToolboxBitmapID: Integer; const LicStr: string; MiscStatus: Integer;
  3095.   ThreadingModel: TThreadingModel);
  3096. begin
  3097.   FWinControlClass := WinControlClass;
  3098.   inherited Create(ComServer, ActiveXControlClass, ClassID, ciMultiInstance,
  3099.     ThreadingModel);
  3100.   FMiscStatus := MiscStatus or
  3101.     OLEMISC_RECOMPOSEONRESIZE or
  3102.     OLEMISC_CANTLINKINSIDE or
  3103.     OLEMISC_INSIDEOUT or
  3104.     OLEMISC_ACTIVATEWHENVISIBLE or
  3105.     OLEMISC_SETCLIENTSITEFIRST;
  3106.   FToolboxBitmapID := ToolboxBitmapID;
  3107.   FVerbs := TStringList.Create;
  3108.   AddVerb(OLEIVERB_PRIMARY, SPropertiesVerb);
  3109.   LicString := LicStr;
  3110.   SupportsLicensing := LicStr <> '';
  3111.   FLicFileStrings := TStringList.Create;
  3112. end;
  3113.  
  3114. destructor TActiveXControlFactory.Destroy;
  3115. begin
  3116.   FVerbs.Free;
  3117.   FLicFileStrings.Free;
  3118.   inherited Destroy;
  3119. end;
  3120.  
  3121. procedure TActiveXControlFactory.AddVerb(Verb: Integer;
  3122.   const VerbName: string);
  3123. begin
  3124.   FVerbs.AddObject(VerbName, TObject(Verb));
  3125. end;
  3126.  
  3127. function TActiveXControlFactory.GetLicenseFileName: string;
  3128. begin
  3129.   Result := ChangeFileExt(ComServer.ServerFileName, '.lic');
  3130. end;
  3131.  
  3132. function TActiveXControlFactory.HasMachineLicense: Boolean;
  3133. var
  3134.   i: Integer;
  3135. begin
  3136.   Result := True;
  3137.   if not SupportsLicensing then Exit;
  3138.   if not FLicenseFileRead then
  3139.   begin
  3140.     try
  3141.       FLicFileStrings.LoadFromFile(GetLicenseFileName);
  3142.       FLicenseFileRead := True;
  3143.     except
  3144.       Result := False;
  3145.     end;
  3146.   end;
  3147.   if Result then
  3148.   begin
  3149.     i := 0;
  3150.     Result := False;
  3151.     while (i < FLicFileStrings.Count) and (not Result) do
  3152.     begin
  3153.       Result := ValidateUserLicense(FLicFileStrings[i]);
  3154.       inc(i);
  3155.     end;
  3156.   end;
  3157. end;
  3158.  
  3159. procedure TActiveXControlFactory.UpdateRegistry(Register: Boolean);
  3160. var
  3161.   ClassKey: string;
  3162.   I: Integer;
  3163. begin
  3164.   ClassKey := 'CLSID\' + GUIDToString(ClassID);
  3165.   if Register then
  3166.   begin
  3167.     inherited UpdateRegistry(Register);
  3168.     CreateRegKey(ClassKey + '\MiscStatus', '', '0');
  3169.     CreateRegKey(ClassKey + '\MiscStatus\1', '', IntToStr(FMiscStatus));
  3170.     CreateRegKey(ClassKey + '\ToolboxBitmap32', '',
  3171.       ComServer.ServerFileName + ',' + IntToStr(FToolboxBitmapID));
  3172.     CreateRegKey(ClassKey + '\Control', '', '');
  3173.     CreateRegKey(ClassKey + '\Verb', '', '');
  3174.     for I := 0 to FVerbs.Count - 1 do
  3175.       CreateRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])),
  3176.         '', FVerbs[I] + ',0,2');
  3177.   end else
  3178.   begin
  3179.     for I := 0 to FVerbs.Count - 1 do
  3180.       DeleteRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])));
  3181.     DeleteRegKey(ClassKey + '\Verb');
  3182.     DeleteRegKey(ClassKey + '\Control');
  3183.     DeleteRegKey(ClassKey + '\ToolboxBitmap32');
  3184.     DeleteRegKey(ClassKey + '\MiscStatus\1');
  3185.     DeleteRegKey(ClassKey + '\MiscStatus');
  3186.     inherited UpdateRegistry(Register);
  3187.   end;
  3188. end;
  3189.  
  3190. { TActiveFormControl }
  3191.  
  3192. procedure TActiveFormControl.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
  3193. begin
  3194.   if FControl is TActiveForm then
  3195.     TActiveForm(FControl).DefinePropertyPages(DefinePropertyPage);
  3196. end;
  3197.  
  3198. procedure TActiveFormControl.FreeOnRelease;
  3199. begin
  3200. end;
  3201.  
  3202. procedure TActiveFormControl.InitializeControl;
  3203. begin
  3204.   inherited InitializeControl;
  3205.   FControl.VCLComObject := Pointer(Self as IVCLComObject);
  3206.   if FControl is TActiveForm then
  3207.   begin
  3208.     TActiveForm(FControl).FActiveFormControl := Self;
  3209.     TActiveForm(FControl).Initialize;
  3210.   end;
  3211. end;
  3212.  
  3213. function TActiveFormControl.Invoke(DispID: Integer; const IID: TGUID;
  3214.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  3215.   ArgErr: Pointer): HResult;
  3216. const
  3217.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  3218. begin
  3219.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  3220.   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
  3221.     Integer(Control) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
  3222.     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  3223. end;
  3224.  
  3225. function TActiveFormControl.ObjQueryInterface(const IID: TGUID; out Obj): HResult;
  3226. begin
  3227.   Result := S_OK;
  3228.   if not Control.GetInterface(IID, Obj) then
  3229.     Result := inherited ObjQueryInterface(IID, Obj);
  3230. end;
  3231.  
  3232. procedure TActiveFormControl.EventSinkChanged(const EventSink: IUnknown);
  3233. begin
  3234.   if (Control is TActiveForm) then
  3235.     TActiveForm(Control).EventSinkChanged(EventSink);
  3236. end;
  3237.  
  3238. { TActiveForm }
  3239.  
  3240. procedure TActiveForm.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
  3241. begin
  3242. end;
  3243.  
  3244. procedure TActiveForm.EventSinkChanged(const EventSink: IUnknown);
  3245. begin
  3246. end;
  3247.  
  3248. procedure TActiveForm.Initialize;
  3249. begin
  3250. end;
  3251.  
  3252. { TActiveFormFactory }
  3253.  
  3254. function TActiveFormFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
  3255. begin
  3256.   Result := WinControlClass.GetInterfaceEntry(Guid);
  3257. end;
  3258.  
  3259. { TPropertyPage }
  3260.  
  3261. constructor TPropertyPage.Create(AOwner: TComponent);
  3262. begin
  3263.   inherited Create(AOwner);
  3264.   FOleObjects := TInterfaceList.Create;
  3265. end;
  3266.  
  3267. destructor TPropertyPage.Destroy;
  3268. begin
  3269.   FOleObjects.Free;
  3270.   inherited Destroy;
  3271. end;
  3272.  
  3273. procedure TPropertyPage.CMChanged(var Msg: TCMChanged);
  3274. begin
  3275.   Modified;
  3276. end;
  3277.  
  3278. procedure TPropertyPage.Modified;
  3279. begin
  3280.   if Assigned(FActiveXPropertyPage) then FActiveXPropertyPage.Modified;
  3281. end;
  3282.  
  3283. procedure TPropertyPage.UpdateObject;
  3284. begin
  3285. end;
  3286.  
  3287. procedure TPropertyPage.EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  3288. begin
  3289.   EnumDispatchProperties(IUnknown(FOleObject) as IDispatch, PropType, VT_EMPTY,
  3290.     PropNames);
  3291. end;
  3292.  
  3293. procedure TPropertyPage.UpdatePropertyPage;
  3294. begin
  3295. end;
  3296.  
  3297. { TActiveXPropertyPage }
  3298.  
  3299. destructor TActiveXPropertyPage.Destroy;
  3300. begin
  3301.   FPropertyPageImpl.FPropertyPage.Free;
  3302.   FPropertyPageImpl.Free;
  3303. end;
  3304.  
  3305. procedure TActiveXPropertyPage.Initialize;
  3306. begin
  3307.   FPropertyPageImpl := TPropertyPageImpl.Create(Self);
  3308.   FPropertyPageImpl.FPropertyPage := TPropertyPageClass(Factory.ComClass).Create(nil);
  3309.   FPropertyPageImpl.InitPropertyPage;
  3310. end;
  3311.  
  3312. { TPropertyPageImpl }
  3313.  
  3314. procedure TPropertyPageImpl.InitPropertyPage;
  3315. begin
  3316.   FPropertyPage.FActiveXPropertyPage := Self;
  3317.   FPropertyPage.BorderStyle := bsNone;
  3318.   FPropertyPage.Position := poDesigned;
  3319. end;
  3320.  
  3321. procedure TPropertyPageImpl.Modified;
  3322. begin
  3323.   if FActive then
  3324.   begin
  3325.     FModified := True;
  3326.     if FPageSite <> nil then
  3327.       FPageSite.OnStatusChange(PROPPAGESTATUS_DIRTY or PROPPAGESTATUS_VALIDATE);
  3328.   end;
  3329. end;
  3330.  
  3331. { TPropertyPageImpl.IPropertyPage }
  3332.  
  3333. function TPropertyPageImpl.SetPageSite(const pageSite: IPropertyPageSite): HResult;
  3334. begin
  3335.   FPageSite := pageSite;
  3336.   Result := S_OK;
  3337. end;
  3338.  
  3339. function TPropertyPageImpl.Activate(hwndParent: HWnd; const rc: TRect;
  3340.   bModal: BOOL): HResult;
  3341. begin
  3342.   try
  3343.     FPropertyPage.BoundsRect := rc;
  3344.     FPropertyPage.ParentWindow := hwndParent;
  3345.     if not VarIsNull(FPropertyPage.FOleObject) then
  3346.       FPropertyPage.UpdatePropertyPage;
  3347.     FActive:= True;
  3348.     FModified := False;
  3349.     Result := S_OK;
  3350.   except
  3351.     Result := HandleException;
  3352.   end;
  3353. end;
  3354.  
  3355. function TPropertyPageImpl.Deactivate: HResult;
  3356. begin
  3357.   try
  3358.     FActive := False;
  3359.     FPropertyPage.Hide;
  3360.     FPropertyPage.ParentWindow := 0;
  3361.     Result := S_OK;
  3362.   except
  3363.     Result := HandleException;
  3364.   end;
  3365. end;
  3366.  
  3367. function TPropertyPageImpl.GetPageInfo(out pageInfo: TPropPageInfo): HResult;
  3368. begin
  3369.   try
  3370.     FillChar(pageInfo.pszTitle, SizeOf(pageInfo) - 4, 0);
  3371.     pageInfo.pszTitle := CoAllocString(FPropertyPage.Caption);
  3372.     pageInfo.size.cx := FPropertyPage.Width;
  3373.     pageInfo.size.cy := FPropertyPage.Height;
  3374.     Result := S_OK;
  3375.   except
  3376.     Result := HandleException;
  3377.   end;
  3378. end;
  3379.  
  3380. function TPropertyPageImpl.SetObjects(cObjects: Longint;
  3381.   pUnkList: PUnknownList): HResult;
  3382. var
  3383.   i: Integer;
  3384. begin
  3385.   try
  3386.     FPropertyPage.FOleObject := Null;
  3387.     FPropertyPage.FOleObjects.Clear;
  3388.     if pUnkList = nil then
  3389.     begin
  3390.       Result := E_POINTER;
  3391.       Exit;
  3392.     end;
  3393.     if cObjects > 0 then
  3394.     begin
  3395.       for i := 0 to cObjects - 1 do
  3396.         FPropertyPage.FOleObjects.Add(pUnkList[i]);
  3397.       FPropertyPage.FOleObject := pUnkList[0] as IDispatch;
  3398.     end;
  3399.     Result := S_OK;
  3400.   except
  3401.     Result := HandleException;
  3402.   end;
  3403. end;
  3404.  
  3405. function TPropertyPageImpl.Show(nCmdShow: Integer): HResult;
  3406. begin
  3407.   try
  3408.     FPropertyPage.Visible := nCmdShow <> SW_HIDE;
  3409.     Result := S_OK;
  3410.   except
  3411.     Result := HandleException;
  3412.   end;
  3413. end;
  3414.  
  3415. function TPropertyPageImpl.Move(const rect: TRect): HResult;
  3416. begin
  3417.   try
  3418.     FPropertyPage.BoundsRect := rect;
  3419.     Result := S_OK;
  3420.   except
  3421.     Result := HandleException;
  3422.   end;
  3423. end;
  3424.  
  3425. function TPropertyPageImpl.IsPageDirty: HResult;
  3426. begin
  3427.   if FModified then Result := S_OK else Result := S_FALSE;
  3428. end;
  3429.  
  3430. function TPropertyPageImpl.Apply: HResult;
  3431.  
  3432.   procedure NotifyContainerOfApply;
  3433.   var
  3434.     OleObject: IUnknown;
  3435.     Connections: IConnectionPointContainer;
  3436.     Connection: IConnectionPoint;
  3437.     Enum: IEnumConnections;
  3438.     ConnectData: TConnectData;
  3439.     Fetched: Longint;
  3440.   begin
  3441.     { VB seems to wait for an OnChange call along a IPropetyNotifySink before
  3442.       it will update its property inspector. }
  3443.     OleObject := IUnknown(FPropertyPage.FOleObject);
  3444.     if OleObject.QueryInterface(IConnectionPointContainer, Connections) = S_OK then
  3445.       if Connections.FindConnectionPoint(IPropertyNotifySink, Connection) = S_OK then
  3446.       begin
  3447.         OleCheck(Connection.EnumConnections(Enum));
  3448.         while Enum.Next(1, ConnectData, @Fetched) = S_OK do
  3449.         begin
  3450.           (ConnectData.pUnk as IPropertyNotifySink).OnChanged(DISPID_UNKNOWN);
  3451.           ConnectData.pUnk := nil;
  3452.         end;
  3453.       end;
  3454.   end;
  3455.  
  3456. begin
  3457.   try
  3458.     FPropertyPage.UpdateObject;
  3459.     FModified := False;
  3460.     NotifyContainerOfApply;
  3461.     Result := S_OK;
  3462.   except
  3463.     Result := HandleException;
  3464.   end;
  3465. end;
  3466.  
  3467. function TPropertyPageImpl.Help(pszHelpDir: POleStr): HResult;
  3468. begin
  3469.   Result := E_NOTIMPL;
  3470. end;
  3471.  
  3472. function TPropertyPageImpl.TranslateAccelerator(msg: PMsg): HResult;
  3473. begin
  3474.   try
  3475.     { For some reason VB bashes WS_EX_CONTROLPARENT, set it back }
  3476.     if FPropertyPage.WindowHandle <> 0 then
  3477.       SetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE,
  3478.         GetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE) or
  3479.         WS_EX_CONTROLPARENT);
  3480.     {!!!}
  3481.     Result := S_FALSE;
  3482.   except
  3483.     Result := HandleException;
  3484.   end;
  3485. end;
  3486.  
  3487. { TPropertyPageImpl.IPropertyPage2 }
  3488.  
  3489. function TPropertyPageImpl.EditProperty(dispid: TDispID): HResult;
  3490. begin
  3491.   Result := E_NOTIMPL; {!!!}
  3492. end;
  3493.  
  3494. { TActiveXPropertyPageFactory }
  3495.  
  3496. constructor TActiveXPropertyPageFactory.Create(ComServer: TComServerObject;
  3497.   PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
  3498. begin
  3499.   inherited Create(ComServer, TComClass(PropertyPageClass), ClassID,
  3500.     '', Format('%s property page', [PropertyPageClass.ClassName]),
  3501.     ciMultiInstance);
  3502. end;
  3503.  
  3504. function TActiveXPropertyPageFactory.CreateComObject(
  3505.   const Controller: IUnknown): TComObject;
  3506. begin
  3507.   Result := TActiveXPropertyPage.CreateFromFactory(Self, Controller);
  3508. end;
  3509.  
  3510. { TCustomAdapter }
  3511.  
  3512. constructor TCustomAdapter.Create;
  3513. begin
  3514.   inherited Create;
  3515.   FNotifier := TAdapterNotifier.Create(Self);
  3516. end;
  3517.  
  3518. destructor TCustomAdapter.Destroy;
  3519. begin
  3520.   ReleaseOleObject;
  3521.   inherited Destroy;
  3522. end;
  3523.  
  3524. procedure TCustomAdapter.Changed;
  3525. begin
  3526.   if not Updating then ReleaseOleObject;
  3527. end;
  3528.  
  3529. procedure TCustomAdapter.ConnectOleObject(OleObject: IUnknown);
  3530. begin
  3531.   if FOleObject <> nil then ReleaseOleObject;
  3532.   if OleObject <> nil then
  3533.     InterfaceConnect(OleObject, IPropertyNotifySink, FNotifier, FConnection);
  3534.   FOleObject := OleObject;
  3535. end;
  3536.  
  3537. procedure TCustomAdapter.ReleaseOleObject;
  3538. begin
  3539.   InterfaceDisconnect(FOleObject, IPropertyNotifySink, FConnection);
  3540.   FOleObject := nil;
  3541. end;
  3542.  
  3543. { TAdapterNotifier }
  3544.  
  3545. constructor TAdapterNotifier.Create(Adapter: TCustomAdapter);
  3546. begin
  3547.   inherited Create;
  3548.   FAdapter := Adapter;
  3549. end;
  3550.  
  3551. { TAdapterNotifier.IPropertyNotifySink }
  3552.  
  3553. function TAdapterNotifier.OnChanged(dispid: TDispID): HResult;
  3554. begin
  3555.   try
  3556.     FAdapter.Update;
  3557.     Result := S_OK;
  3558.   except
  3559.     Result := HandleException;
  3560.   end;
  3561. end;
  3562.  
  3563. function TAdapterNotifier.OnRequestEdit(dispid: TDispID): HResult;
  3564. begin
  3565.   Result := S_OK;
  3566. end;
  3567.  
  3568. { TFontAdapter }
  3569.  
  3570. constructor TFontAdapter.Create(Font: TFont);
  3571. begin
  3572.   inherited Create;
  3573.   FFont := Font;
  3574. end;
  3575.  
  3576. procedure TFontAdapter.Update;
  3577. var
  3578.   TempFont: TFont;
  3579.   Name: WideString;
  3580.   Size: Currency;
  3581.   Temp: Longbool;
  3582.   Charset: Smallint;
  3583.   Style: TFontStyles;
  3584.   FOleFont: IFont;
  3585. begin
  3586.   if Updating then Exit;
  3587.   FOleFont := FOleObject as IFont;
  3588.   if FOleFont = nil then Exit;
  3589.   FOleFont.get_Name(Name);
  3590.   FOleFont.get_Size(Size);
  3591.  
  3592.   Style := [];
  3593.   FOleFont.get_Bold(Temp);
  3594.   if Temp then Include(Style, fsBold);
  3595.   FOleFont.get_Italic(Temp);
  3596.   if Temp then Include(Style, fsItalic);
  3597.   FOleFont.get_Underline(Temp);
  3598.   if Temp then Include(Style, fsUnderline);
  3599.   FOleFont.get_Strikethrough(Temp);
  3600.   if Temp then Include(Style, fsStrikeout);
  3601.   FOleFont.get_Charset(Charset);
  3602.  
  3603.   TempFont := TFont.Create;
  3604.   Updating := True;
  3605.   try
  3606.     TempFont.Assign(FFont);
  3607.     TempFont.Name := Name;
  3608.     TempFont.Size := Integer(Round(Size));
  3609.     TempFont.Style := Style;
  3610.     TempFont.Charset := Charset;
  3611.     FFont.Assign(TempFont);
  3612.   finally
  3613.     Updating := False;
  3614.     TempFont.Free;
  3615.   end;
  3616. end;
  3617.  
  3618. procedure TFontAdapter.Changed;
  3619. begin  // TFont has changed.  Need to update IFont
  3620.   if Updating then Exit;
  3621.   if FOleObject = nil then Exit;
  3622.   Updating := True;
  3623.   try
  3624.     with FOleObject as IFont do
  3625.     begin
  3626.       Put_Name(FFont.Name);
  3627.       Put_Size(FFont.Size);
  3628.       Put_Bold(fsBold in FFont.Style);
  3629.       Put_Italic(fsItalic in FFont.Style);
  3630.       Put_Underline(fsUnderline in FFont.Style);
  3631.       Put_Strikethrough(fsStrikeout in FFont.Style);
  3632.       Put_Charset(FFont.Charset);
  3633.     end;
  3634.   finally
  3635.     Updating := False;
  3636.   end;
  3637. end;
  3638.  
  3639. { TFontAdapter.IFontAccess }
  3640.  
  3641. procedure TFontAdapter.GetOleFont(var OleFont: IFontDisp);
  3642. var
  3643.   FontDesc: TFontDesc;
  3644.   FontName: WideString;
  3645.   Temp: IFont;
  3646. begin
  3647.   if FOleObject = nil then
  3648.   begin
  3649.     FontName := FFont.Name;
  3650.     with FontDesc do
  3651.     begin
  3652.       cbSizeOfStruct := SizeOf(FontDesc);
  3653.       lpstrName := PWideChar(FontName);
  3654.       cySize := FFont.Size;
  3655.       if fsBold in FFont.Style then sWeight := 700 else sWeight := 400;
  3656.       sCharset := FFont.Charset;
  3657.       fItalic := fsItalic in FFont.Style;
  3658.       fUnderline := fsUnderline in FFont.Style;
  3659.       fStrikethrough := fsStrikeout in FFont.Style;
  3660.     end;
  3661.     OleCheck(OleCreateFontIndirect(FontDesc, IFont, Temp));
  3662.     ConnectOleObject(Temp);
  3663.   end;
  3664.   OleFont := FOleObject as IFontDisp;
  3665. end;
  3666.  
  3667. procedure TFontAdapter.SetOleFont(const OleFont: IFontDisp);
  3668. begin
  3669.   ConnectOleObject(OleFont as IFont);
  3670.   Update;
  3671. end;
  3672.  
  3673. { TPictureAdapter }
  3674.  
  3675. constructor TPictureAdapter.Create(Picture: TPicture);
  3676. begin
  3677.   inherited Create;
  3678.   FPicture := Picture;
  3679. end;
  3680.  
  3681. procedure TPictureAdapter.Update;
  3682. var
  3683.   Temp: TOleGraphic;
  3684. begin
  3685.   Updating := True;
  3686.   Temp := TOleGraphic.Create;
  3687.   try
  3688.     Temp.Picture := FOleObject as IPicture;
  3689.     FPicture.Graphic := Temp;
  3690.   finally
  3691.     Updating := False;
  3692.     Temp.Free;
  3693.   end;
  3694. end;
  3695.  
  3696. { TPictureAdapter.IPictureAccess }
  3697.  
  3698. procedure TPictureAdapter.GetOlePicture(var OlePicture: IPictureDisp);
  3699. var
  3700.   PictureDesc: TPictDesc;
  3701.   OwnHandle: Boolean;
  3702.   TempM: TMetafile;
  3703.   TempB: TBitmap;
  3704. begin
  3705.   if FOleObject = nil then
  3706.   begin
  3707.     OwnHandle := False;
  3708.     with PictureDesc do
  3709.     begin
  3710.       cbSizeOfStruct := SizeOf(PictureDesc);
  3711.       if FPicture.Graphic is TBitmap then
  3712.       begin
  3713.         picType := PICTYPE_BITMAP;
  3714.         TempB := TBitmap.Create;
  3715.         try
  3716.           TempB.Assign(FPicture.Graphic);
  3717.           hbitmap := TempB.ReleaseHandle;
  3718.           hpal := TempB.ReleasePalette;
  3719.           OwnHandle := True;
  3720.         finally
  3721.           TempB.Free;
  3722.         end;
  3723.       end
  3724.       else if FPicture.Graphic is TIcon then
  3725.       begin
  3726.         picType := PICTYPE_ICON;
  3727.         hicon := FPicture.Icon.Handle;
  3728.       end
  3729.       else
  3730.       begin
  3731.         picType := PICTYPE_ENHMETAFILE;
  3732.         if not (FPicture.Graphic is TMetafile) then
  3733.         begin
  3734.           TempM := TMetafile.Create;
  3735.           try
  3736.             TempM.Width := FPicture.Width;
  3737.             TempM.Height := FPicture.Height;
  3738.             with TMetafileCanvas.Create(TempM,0) do
  3739.             try
  3740.               Draw(0,0,FPicture.Graphic);
  3741.             finally
  3742.               Free;
  3743.             end;
  3744.             hemf := TempM.ReleaseHandle;
  3745.             OwnHandle := True;   // IPicture destroys temp metafile when released
  3746.           finally
  3747.             TempM.Free;
  3748.           end;
  3749.         end
  3750.         else
  3751.           hemf := FPicture.Metafile.Handle;
  3752.       end;
  3753.     end;
  3754.     OleCheck(OleCreatePictureIndirect(PictureDesc, IPicture, OwnHandle, OlePicture));
  3755.     ConnectOleObject(OlePicture);
  3756.   end;
  3757.   OlePicture := FOleObject as IPictureDisp;
  3758. end;
  3759.  
  3760. procedure TPictureAdapter.SetOlePicture(const OlePicture: IPictureDisp);
  3761. begin
  3762.   ConnectOleObject(OlePicture);
  3763.   Update;
  3764. end;
  3765.  
  3766. { TOleGraphic }
  3767.  
  3768. procedure TOleGraphic.Assign(Source: TPersistent);
  3769. begin
  3770.   if Source is TOleGraphic then
  3771.     FPicture := TOleGraphic(Source).Picture
  3772.   else
  3773.     inherited Assign(Source);
  3774. end;
  3775.  
  3776. procedure TOleGraphic.Changed(Sender: TObject);
  3777. begin
  3778.   //!!
  3779. end;
  3780.  
  3781. procedure TOleGraphic.Draw(ACanvas: TCanvas; const Rect: TRect);
  3782. var
  3783.   DC: HDC;
  3784.   Pal: HPalette;
  3785.   RestorePalette: Boolean;
  3786.   PicType: SmallInt;
  3787.   hemf: HENHMETAFILE;
  3788. begin
  3789.   if FPicture = nil then Exit;
  3790.   ACanvas.Lock;  // OLE calls might cycle the message loop
  3791.   try
  3792.     DC := ACanvas.Handle;
  3793.     Pal := Palette;
  3794.     RestorePalette := False;
  3795.     if Pal <> 0 then
  3796.     begin
  3797.       Pal := SelectPalette(DC, Pal, True);
  3798.       RealizePalette(DC);
  3799.       RestorePalette := True;
  3800.     end;
  3801.     FPicture.get_Type(PicType);
  3802.     if PicType = PICTYPE_ENHMETAFILE then
  3803.     begin
  3804.       FPicture.get_Handle(hemf);
  3805.       PlayEnhMetafile(DC, hemf, Rect);
  3806.     end
  3807.     else
  3808.       OleCheck(FPicture.Render(DC, Rect.Left, Rect.Top, Rect.Right,
  3809.         Rect.Bottom, 0, MMHeight, MMWidth, -MMHeight, Rect));
  3810.     if RestorePalette then
  3811.       SelectPalette(DC, Pal, True);
  3812.   finally
  3813.     ACanvas.Unlock;
  3814.   end;
  3815. end;
  3816.  
  3817. function TOleGraphic.GetEmpty: Boolean;
  3818. var
  3819.   PicType: Smallint;
  3820. begin
  3821.   Result := (FPicture = nil) or (FPicture.get_Type(PicType) <> 0) or (PicType <= 0);
  3822. end;
  3823.  
  3824. function HIMETRICtoDP(P: TPoint): TPoint;
  3825. var
  3826.   DC: HDC;
  3827. begin
  3828.   DC := GetDC(0);
  3829.   SetMapMode(DC, MM_HIMETRIC);
  3830.   Result := P;
  3831.   Result.Y := -Result.Y;
  3832.   LPTODP(DC, Result, 1);
  3833.   ReleaseDC(0,DC);
  3834. end;
  3835.  
  3836. function TOleGraphic.GetHeight: Integer;
  3837. begin
  3838.   Result := HIMETRICtoDP(Point(0, MMHeight)).Y;
  3839. end;
  3840.  
  3841. function TOleGraphic.GetMMHeight: Integer;
  3842. begin
  3843.   Result := 0;
  3844.   if FPicture <> nil then FPicture.get_Height(Result);
  3845. end;
  3846.  
  3847. function TOleGraphic.GetMMWidth: Integer;
  3848. begin
  3849.   Result := 0;
  3850.   if FPicture <> nil then FPicture.get_Width(Result);
  3851. end;
  3852.  
  3853. function TOleGraphic.GetPalette: HPALETTE;
  3854. var
  3855.   Handle: OLE_HANDLE;
  3856. begin
  3857.   Result := 0;
  3858.   if FPicture <> nil then
  3859.   begin
  3860.     FPicture.Get_HPal(Handle);
  3861.     Result := HPALETTE(Handle);
  3862.   end;
  3863. end;
  3864.  
  3865. function TOleGraphic.GetTransparent: Boolean;
  3866. var
  3867.   Attr: Integer;
  3868. begin
  3869.   Result := False;
  3870.   if FPicture <> nil then
  3871.   begin
  3872.     FPicture.Get_Attributes(Attr);
  3873.     Result := (Attr and PICTURE_TRANSPARENT) <> 0;
  3874.   end;
  3875. end;
  3876.  
  3877. function TOleGraphic.GetWidth: Integer;
  3878. begin
  3879.   Result := HIMETRICtoDP(Point(MMWidth,0)).X;
  3880. end;
  3881.  
  3882. procedure InvalidOperation(const Str: string);
  3883. begin
  3884.   raise EInvalidGraphicOperation.Create(Str);
  3885. end;
  3886.  
  3887. procedure TOleGraphic.SetHeight(Value: Integer);
  3888. begin
  3889.   InvalidOperation(sOleGraphic);
  3890. end;
  3891.  
  3892. procedure TOleGraphic.SetPalette(Value: HPALETTE);
  3893. begin
  3894.   if FPicture <> nil then OleCheck(FPicture.Set_hpal(Value));
  3895. end;
  3896.  
  3897. procedure TOleGraphic.SetWidth(Value: Integer);
  3898. begin
  3899.   InvalidOperation(sOleGraphic);
  3900. end;
  3901.  
  3902. procedure TOleGraphic.LoadFromFile(const Filename: string);
  3903. begin
  3904.   //!!
  3905. end;
  3906.  
  3907. procedure TOleGraphic.LoadFromStream(Stream: TStream);
  3908. begin
  3909.   OleCheck(OleLoadPicture(TStreamAdapter.Create(Stream), 0, True, IPicture,
  3910.     FPicture));
  3911. end;
  3912.  
  3913. procedure TOleGraphic.SaveToStream(Stream: TStream);
  3914. begin
  3915.   OleCheck((FPicture as IPersistStream).Save(TStreamAdapter.Create(Stream), True));
  3916. end;
  3917.  
  3918. procedure TOleGraphic.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3919.   APalette: HPALETTE);
  3920. begin
  3921.   InvalidOperation(sOleGraphic);
  3922. end;
  3923.  
  3924. procedure TOleGraphic.SaveToClipboardFormat(var AFormat: Word;
  3925.   var AData: THandle; var APalette: HPALETTE);
  3926. begin
  3927.   InvalidOperation(sOleGraphic);
  3928. end;
  3929.  
  3930.  
  3931. type
  3932.   TStringsEnumerator = class(TContainedObject, IEnumString)
  3933.   private
  3934.     FIndex: Integer;  // index of next unread string
  3935.     FStrings: IStrings;
  3936.   public
  3937.     constructor Create(const Strings: IStrings);
  3938.     function Next(celt: Longint; out elt;
  3939.       pceltFetched: PLongint): HResult; stdcall;
  3940.     function Skip(celt: Longint): HResult; stdcall;
  3941.     function Reset: HResult; stdcall;
  3942.     function Clone(out enm: IEnumString): HResult; stdcall;
  3943.   end;
  3944.  
  3945. constructor TStringsEnumerator.Create(const Strings: IStrings);
  3946. begin
  3947.   inherited Create(Strings);
  3948.   FStrings := Strings;
  3949. end;
  3950.  
  3951. function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
  3952. var
  3953.   I: Integer;
  3954. begin
  3955.   I := 0;
  3956.   while (I < celt) and (FIndex < FStrings.Count) do
  3957.   begin
  3958.     TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[I]));
  3959.     Inc(I);
  3960.     Inc(FIndex);
  3961.   end;
  3962.   if pceltFetched <> nil then pceltFetched^ := I;
  3963.   if I = celt then Result := S_OK else Result := S_FALSE;
  3964. end;
  3965.  
  3966. function TStringsEnumerator.Skip(celt: Longint): HResult;
  3967. begin
  3968.   if (FIndex + celt) <= FStrings.Count then
  3969.   begin
  3970.     Inc(FIndex, celt);
  3971.     Result := S_OK;
  3972.   end
  3973.   else
  3974.   begin
  3975.     FIndex := FStrings.Count;
  3976.     Result := S_FALSE;
  3977.   end;
  3978. end;
  3979.  
  3980. function TStringsEnumerator.Reset: HResult;
  3981. begin
  3982.   FIndex := 0;
  3983.   Result := S_OK;
  3984. end;
  3985.  
  3986. function TStringsEnumerator.Clone(out enm: IEnumString): HResult;
  3987. begin
  3988.   try
  3989.     enm := TStringsEnumerator.Create(FStrings);
  3990.     Result := S_OK;
  3991.   except
  3992.     Result := E_UNEXPECTED;
  3993.   end;
  3994. end;
  3995.  
  3996. { TStringsAdapter }
  3997.  
  3998. constructor TStringsAdapter.Create(Strings: TStrings);
  3999. var
  4000.   StdVcl: ITypeLib;
  4001. begin
  4002.   OleCheck(LoadRegTypeLib(LIBID_STDVCL, 1, 0, 0, StdVcl));
  4003.   inherited Create(StdVcl, IStrings);
  4004.   FStrings := Strings;
  4005. end;
  4006.  
  4007. procedure TStringsAdapter.ReferenceStrings(S: TStrings);
  4008. begin
  4009.   FStrings := S;
  4010. end;
  4011.  
  4012. procedure TStringsAdapter.ReleaseStrings;
  4013. begin
  4014.   FStrings := nil;
  4015. end;
  4016.  
  4017. function TStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant;
  4018. begin
  4019.   Result := Get_Item(Index);
  4020. end;
  4021.  
  4022. procedure TStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant);
  4023. begin
  4024.   Set_Item(Index, Value);
  4025. end;
  4026.  
  4027. function TStringsAdapter.Count: Integer;
  4028. begin
  4029.   Result := 0;
  4030.   if FStrings <> nil then Result := FStrings.Count;
  4031. end;
  4032.  
  4033. function TStringsAdapter.Get_Item(Index: Integer): OleVariant;
  4034. begin
  4035.   Result := NULL;
  4036.   if (FStrings <> nil) then Result := WideString(FStrings[Index]);
  4037. end;
  4038.  
  4039. procedure TStringsAdapter.Set_Item(Index: Integer; Value: OleVariant);
  4040. begin
  4041.   if (FStrings <> nil) then FStrings[Index] := Value;
  4042. end;
  4043.  
  4044. procedure TStringsAdapter.Remove(Index: Integer);
  4045. begin
  4046.   if FStrings <> nil then FStrings.Delete(Index);
  4047. end;
  4048.  
  4049. procedure TStringsAdapter.Clear;
  4050. begin
  4051.   if FStrings <> nil then FStrings.Clear;
  4052. end;
  4053.  
  4054. function TStringsAdapter.Add(Item: OleVariant): Integer;
  4055. begin
  4056.   Result := -1;
  4057.   if FStrings <> nil then Result := FStrings.Add(Item);
  4058. end;
  4059.  
  4060. function TStringsAdapter._NewEnum: IUnknown;
  4061. begin
  4062.   Result := TStringsEnumerator.Create(Self);
  4063. end;
  4064.  
  4065. procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
  4066. begin
  4067.   OleStrings := nil;
  4068.   if Strings = nil then Exit;
  4069.   if Strings.StringsAdapter = nil then
  4070.     Strings.StringsAdapter := TStringsAdapter.Create(Strings);
  4071.   OleStrings := Strings.StringsAdapter as IStrings;
  4072. end;
  4073.  
  4074. procedure SetOleStrings(Strings: TStrings; OleStrings: IStrings);
  4075. var
  4076.   I: Integer;
  4077. begin
  4078.   if Strings = nil then Exit;
  4079.   Strings.BeginUpdate;
  4080.   try
  4081.     Strings.Clear;
  4082.     for I := 0 to OleStrings.Count-1 do
  4083.       Strings.Add(OleStrings.Item[I]);
  4084.   finally
  4085.     Strings.EndUpdate;
  4086.   end;
  4087. end;
  4088.  
  4089. { Dynamically load functions used in OLEPRO32.DLL }
  4090.  
  4091. var
  4092.   OlePro32DLL: THandle;
  4093.   _OleCreatePropertyFrame: function(hwndOwner: HWnd; x, y: Integer;
  4094.     lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  4095.     pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  4096.     pvReserved: Pointer): HResult stdcall;
  4097.   _OleCreateFontIndirect: function(const FontDesc: TFontDesc; const iid: TIID;
  4098.     out vObject): HResult stdcall;
  4099.   _OleCreatePictureIndirect: function(const PictDesc: TPictDesc; const iid: TIID;
  4100.     fOwn: BOOL; out vObject): HResult stdcall;
  4101.   _OleLoadPicture: function(stream: IStream; lSize: Longint; fRunmode: BOOL;
  4102.     const iid: TIID; out vObject): HResult; stdcall;
  4103.  
  4104. procedure InitOlePro32;
  4105. begin
  4106.   if OlePro32Dll <> 0 then Exit;
  4107.   OlePro32Dll := SafeLoadLibrary('olepro32.dll');
  4108.   if OlePro32DLL <> 0 then
  4109.   begin
  4110.     @_OleCreatePropertyFrame := GetProcAddress(OlePro32DLL, 'OleCreatePropertyFrame');
  4111.     @_OleCreateFontIndirect := GetProcAddress(OlePro32DLL, 'OleCreateFontIndirect');
  4112.     @_OleCreatePictureIndirect := GetProcAddress(OlePro32DLL, 'OleCreatePictureIndirect');
  4113.     @_OleLoadPicture := GetProcAddress(OlePro32DLL, 'OleLoadPicture');
  4114.   end;
  4115. end;
  4116.  
  4117. function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
  4118.   lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  4119.   pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  4120.   pvReserved: Pointer): HResult;
  4121. begin
  4122.   if Assigned(_OleCreatePropertyFrame) then
  4123.     Result := _OleCreatePropertyFrame(hwndOwner, x, y, lpszCaption, cObjects,
  4124.       pObjects, cPages, pPageCLSIDs, lcid, dwReserved, pvReserved)
  4125.   else
  4126.     Result := E_UNEXPECTED;
  4127. end;
  4128.  
  4129. function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
  4130.   out vObject): HResult;
  4131. begin
  4132.   if Assigned(_OleCreateFontIndirect) then
  4133.     Result := _OleCreateFontIndirect(FontDesc, iid, vObject)
  4134.   else
  4135.     Result := E_UNEXPECTED;
  4136. end;
  4137.  
  4138. function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
  4139.   fOwn: BOOL; out vObject): HResult;
  4140. begin
  4141.   if Assigned(_OleCreatePictureIndirect) then
  4142.     Result := _OleCreatePictureIndirect(PictDesc, iid, fOwn, vObject)
  4143.   else
  4144.     Result := E_UNEXPECTED;
  4145. end;
  4146.  
  4147. function OleLoadPicture(stream: IStream; lSize: Longint; fRunmode: BOOL;
  4148.   const iid: TIID; out vObject): HResult;
  4149. begin
  4150.   if Assigned(_OleLoadPicture) then
  4151.     Result := _OleLoadPicture(stream, lSize, fRunmode, iid, vObject)
  4152.   else
  4153.     Result := E_UNEXPECTED;
  4154. end;
  4155.  
  4156. initialization
  4157.   TPicture.RegisterFileFormat('', '', TOleGraphic);
  4158.   InitOlePro32;
  4159.  
  4160. finalization
  4161.   if xParkingWindow <> 0 then
  4162.     SendMessage(xParkingWindow, WM_CLOSE, 0, 0);
  4163.   if OlePro32DLL <> 0 then FreeLibrary(OlePro32DLL);
  4164.  
  4165. end.
  4166.