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