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