home *** CD-ROM | disk | FTP | other *** search
/ PC Pro 1999 February / DPPCPRO0299.ISO / February / Delphi / Install / DATA.Z / OLECTRLS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1996-06-09  |  70.4 KB  |  2,566 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Delphi Visual Component Library                 }
  5. {                                                       }
  6. {       Copyright (c) 1996 Borland International        }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. unit OleCtrls;
  11.  
  12. {$R-}
  13.  
  14. interface
  15.  
  16. uses Windows, Messages, Ole2, OleCtl, SysUtils, Classes, Controls, Forms,
  17.   Menus, Graphics, OleAuto;
  18.  
  19. type
  20.  
  21.   TOleControl = class;
  22.  
  23.   TOleClientSite = class(IOleClientSite)
  24.   private
  25.     FControl: TOleControl;
  26.   public
  27.     constructor Create(Control: TOleControl);
  28.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  29.     function AddRef: Longint; override;
  30.     function Release: Longint; override;
  31.     function SaveObject: HResult; override;
  32.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  33.       var mk: IMoniker): HResult; override;
  34.     function GetContainer(var container: IOleContainer): HResult; override;
  35.     function ShowObject: HResult; override;
  36.     function OnShowWindow(fShow: BOOL): HResult; override;
  37.     function RequestNewObjectLayout: HResult; override;
  38.   end;
  39.  
  40.   TOleControlSite = class(IOleControlSite)
  41.   private
  42.     FControl: TOleControl;
  43.   public
  44.     constructor Create(Control: TOleControl);
  45.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  46.     function AddRef: Longint; override;
  47.     function Release: Longint; override;
  48.     function OnControlInfoChanged: HResult; override;
  49.     function LockInPlaceActive(fLock: BOOL): HResult; override;
  50.     function GetExtendedControl(var disp: IDispatch): HResult; override;
  51.     function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
  52.       flags: Longint): HResult; override;
  53.     function TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;
  54.        override;
  55.     function OnFocus(fGotFocus: BOOL): HResult; override;
  56.     function ShowPropertyFrame: HResult; override;
  57.   end;
  58.  
  59.   TOleInPlaceSite = class(IOleInPlaceSite)
  60.   private
  61.     FControl: TOleControl;
  62.   public
  63.     constructor Create(Control: TOleControl);
  64.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  65.     function AddRef: Longint; override;
  66.     function Release: Longint; override;
  67.     function GetWindow(var wnd: HWnd): HResult; override;
  68.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; override;
  69.     function CanInPlaceActivate: HResult; override;
  70.     function OnInPlaceActivate: HResult; override;
  71.     function OnUIActivate: HResult; override;
  72.     function GetWindowContext(var frame: IOleInPlaceFrame;
  73.       var doc: IOleInPlaceUIWindow; var rcPosRect: TRect;
  74.       var rcClipRect: TRect; var frameInfo: TOleInPlaceFrameInfo): HResult;
  75.       override;
  76.     function Scroll(const scrollExtent: TPoint): HResult; override;
  77.     function OnUIDeactivate(fUndoable: BOOL): HResult; override;
  78.     function OnInPlaceDeactivate: HResult; override;
  79.     function DiscardUndoState: HResult; override;
  80.     function DeactivateAndUndo: HResult; override;
  81.     function OnPosRectChange(const rcPosRect: TRect): HResult; override;
  82.   end;
  83.  
  84.   TOleInPlaceFrame = class(IOleInPlaceFrame)
  85.   private
  86.     FControl: TOleControl;
  87.   public
  88.     constructor Create(Control: TOleControl);
  89.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  90.     function AddRef: Longint; override;
  91.     function Release: Longint; override;
  92.     function GetWindow(var wnd: HWnd): HResult; override;
  93.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; override;
  94.     function GetBorder(var rectBorder: TRect): HResult; override;
  95.     function RequestBorderSpace(const borderwidths: TRect): HResult; override;
  96.     function SetBorderSpace(pborderwidths: PRect): HResult; override;
  97.     function SetActiveObject(activeObject: IOleInPlaceActiveObject;
  98.       pszObjName: POleStr): HResult; override;
  99.     function InsertMenus(hmenuShared: HMenu;
  100.       var menuWidths: TOleMenuGroupWidths): HResult; override;
  101.     function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  102.       hwndActiveObject: HWnd): HResult; override;
  103.     function RemoveMenus(hmenuShared: HMenu): HResult; override;
  104.     function SetStatusText(pszStatusText: POleStr): HResult; override;
  105.     function EnableModeless(fEnable: BOOL): HResult; override;
  106.     function TranslateAccelerator(var msg: TMsg; wID: Word): HResult; override;
  107.   end;
  108.  
  109.   TAmbientDispatch = class(IDispatch)
  110.   private
  111.     FControl: TOleControl;
  112.   public
  113.     constructor Create(Control: TOleControl);
  114.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  115.     function AddRef: Longint; override;
  116.     function Release: Longint; override;
  117.     function GetTypeInfoCount(var ctinfo: Integer): HResult; override;
  118.     function GetTypeInfo(itinfo: Integer; lcid: TLCID;
  119.       var tinfo: ITypeInfo): HResult; override;
  120.     function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
  121.       cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override;
  122.     function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
  123.       flags: Word; var dispParams: TDispParams; varResult: PVariant;
  124.       excepInfo: PExcepInfo; argErr: PInteger): HResult; override;
  125.   end;
  126.  
  127.   TEventDispatch = class(IDispatch)
  128.   private
  129.     FControl: TOleControl;
  130.   public
  131.     constructor Create(Control: TOleControl);
  132.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  133.     function AddRef: Longint; override;
  134.     function Release: Longint; override;
  135.     function GetTypeInfoCount(var ctinfo: Integer): HResult; override;
  136.     function GetTypeInfo(itinfo: Integer; lcid: TLCID;
  137.       var tinfo: ITypeInfo): HResult; override;
  138.     function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList;
  139.       cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override;
  140.     function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID;
  141.       flags: Word; var dispParams: TDispParams; varResult: PVariant;
  142.       excepInfo: PExcepInfo; argErr: PInteger): HResult; override;
  143.   end;
  144.  
  145.   TPropertyNotifySink = class(IPropertyNotifySink)
  146.   private
  147.     FControl: TOleControl;
  148.   public
  149.     constructor Create(Control: TOleControl);
  150.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  151.     function AddRef: Longint; override;
  152.     function Release: Longint; override;
  153.     function OnChanged(dispid: TDispID): HResult; override;
  154.     function OnRequestEdit(dispid: TDispID): HResult; override;
  155.   end;
  156.  
  157.   TSimpleFrameSite = class(ISimpleFrameSite)
  158.   private
  159.     FControl: TOleControl;
  160.   public
  161.     constructor Create(Control: TOleControl);
  162.     function QueryInterface(const iid: TIID; var obj): HResult; override;
  163.     function AddRef: Longint; override;
  164.     function Release: Longint; override;
  165.     function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  166.       var res: Integer; var Cookie: Longint): HResult; override;
  167.     function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  168.       var res: Integer; Cookie: Longint): HResult; override;
  169.   end;
  170.  
  171.   TOleEnum = -32768..32767;
  172.  
  173.   TEnumValue = record
  174.     Value: Longint;
  175.     Ident: string;
  176.   end;
  177.  
  178.   PEnumValueList = ^TEnumValueList;
  179.   TEnumValueList = array[0..32767] of TEnumValue;
  180.  
  181.   TEnumPropDesc = class
  182.   private
  183.     FDispID: Integer;
  184.     FValueCount: Integer;
  185.     FValues: PEnumValueList;
  186.   public
  187.     constructor Create(DispID, ValueCount: Integer; TypeInfo: ITypeInfo);
  188.     destructor Destroy; override;
  189.     procedure GetStrings(Proc: TGetStrProc);
  190.     function StringToValue(const S: string): Integer;
  191.     function ValueToString(V: Integer): string;
  192.   end;
  193.  
  194.   PControlData = ^TControlData;
  195.   TControlData = record
  196.     ClassID: TCLSID;
  197.     EventIID: TIID;
  198.     EventCount: Longint;
  199.     EventDispIDs: Pointer;
  200.     LicenseKey: Pointer;
  201.     Flags: Integer;
  202.     InstanceCount: Integer;
  203.     EnumPropDescs: TList;
  204.   end;
  205.  
  206.   TOleControl = class(TWinControl)
  207.   private
  208.     FControlData: PControlData;
  209.     FRefCount: Longint;
  210.     FOleClientSite: TOleClientSite;
  211.     FOleControlSite: TOleControlSite;
  212.     FOleInPlaceSite: TOleInPlaceSite;
  213.     FOleInPlaceFrame: TOleInPlaceFrame;
  214.     FAmbientDispatch: TAmbientDispatch;
  215.     FEventDispatch: TEventDispatch;
  216.     FPropertyNotifySink: TPropertyNotifySink;
  217.     FSimpleFrameSite: TSimpleFrameSite;
  218.     FObjectData: HGlobal;
  219.     FOleObject: IOleObject;
  220.     FPersistStream: IPersistStreamInit;
  221.     FOleControl: IOleControl;
  222.     FControlDispatch: IDispatch;
  223.     FPropBrowsing: IPerPropertyBrowsing;
  224.     FOleInPlaceObject: IOleInPlaceObject;
  225.     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
  226.     FPropConnection: Longint;
  227.     FEventsConnection: Longint;
  228.     FMiscStatus: Longint;
  229.     FUpdatingColor: Boolean;
  230.     FUpdatingFont: Boolean;
  231.     FUpdatingEnabled: Boolean;
  232.     function AddRef: Longint;
  233.     procedure CreateControl;
  234.     procedure CreateEnumPropDescs;
  235.     procedure CreateInstance;
  236.     procedure CreateStorage;
  237.     procedure DesignModified;
  238.     procedure DestroyControl;
  239.     procedure DestroyEnumPropDescs;
  240.     procedure DestroyStorage;
  241.     procedure GetEventMethod(DispID: TDispID; var Method: TMethod);
  242.     function GetMainMenu: TMainMenu;
  243.     function GetOleObject: Variant;
  244.     procedure HookControlWndProc;
  245.     procedure InvokeEvent(DispID: TDispID; var Params: TDispParams);
  246.     function QueryInterface(const iid: TIID; var obj): HResult;
  247.     procedure ReadData(Stream: TStream);
  248.     function Release: Longint;
  249.     procedure SetUIActive(Active: Boolean);
  250.     procedure StandardEvent(DispID: TDispID; var Params: TDispParams);
  251.     procedure WriteData(Stream: TStream);
  252.     procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
  253.     procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
  254.     procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
  255.     procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
  256.     procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  257.     procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
  258.     procedure CMDialogKey(var Message: TMessage); message CM_DIALOGKEY;
  259.     procedure CMUIActivate(var Message: TMessage); message CM_UIACTIVATE;
  260.     procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
  261.   protected
  262.     FEvents: Integer;
  263.     procedure CreateWnd; override;
  264.     procedure DefaultHandler(var Message); override;
  265.     procedure DefineProperties(Filer: TFiler); override;
  266.     procedure DestroyWindowHandle; override;
  267.     function GetColorProp(Index: Integer): TColor;
  268.     function GetCurrencyProp(Index: Integer): TCurrency;
  269.     function GetDoubleProp(Index: Integer): Double;
  270.     function GetIntegerProp(Index: Integer): Integer;
  271.     function GetOleBoolProp(Index: Integer): TOleBool;
  272.     function GetOleDateProp(Index: Integer): TOleDate;
  273.     function GetOleEnumProp(Index: Integer): TOleEnum;
  274.     procedure GetProperty(Index: Integer; var Value: TVarData);
  275.     function GetSingleProp(Index: Integer): Single;
  276.     function GetSmallintProp(Index: Integer): Smallint;
  277.     function GetStringProp(Index: Integer): string;
  278.     function GetVariantProp(Index: Integer): Variant;
  279.     procedure InitControlData; virtual; abstract;
  280.     procedure InvokeMethod(var DispInfo; Result: Pointer);
  281.     function PaletteChanged(Foreground: Boolean): Boolean; override;
  282.     procedure SetColorProp(Index: Integer; Value: TColor);
  283.     procedure SetCurrencyProp(Index: Integer; Value: TCurrency);
  284.     procedure SetDoubleProp(Index: Integer; Value: Double);
  285.     procedure SetIntegerProp(Index: Integer; Value: Integer);
  286.     procedure SetName(const Value: TComponentName); override;
  287.     procedure SetOleBoolProp(Index: Integer; Value: TOleBool);
  288.     procedure SetOleDateProp(Index: Integer; Value: TOleDate);
  289.     procedure SetOleEnumProp(Index: Integer; Value: TOleEnum);
  290.     procedure SetProperty(Index: Integer; const Value: TVarData);
  291.     procedure SetSingleProp(Index: Integer; Value: Single);
  292.     procedure SetSmallintProp(Index: Integer; Value: Smallint);
  293.     procedure SetStringProp(Index: Integer; const Value: string);
  294.     procedure SetVariantProp(Index: Integer; const Value: Variant);
  295.     procedure WndProc(var Message: TMessage); override;
  296.     property ControlData: PControlData read FControlData write FControlData;
  297.   public
  298.     constructor Create(AOwner: TComponent); override;
  299.     destructor Destroy; override;
  300.     procedure BrowseProperties;
  301.     procedure DoObjectVerb(Verb: Integer);
  302.     function GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
  303.     function GetHelpContext(Member: string; var HelpCtx: Integer;
  304.       var HelpFile: string): Boolean;
  305.     procedure GetObjectVerbs(List: TStrings);
  306.     function GetPropDisplayString(DispID: Integer): string;
  307.     procedure GetPropDisplayStrings(DispID: Integer; List: TStrings);
  308.     function IsCustomProperty(DispID: Integer): Boolean;
  309.     procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
  310.     procedure SetPropDisplayString(DispID: Integer; const Value: string);
  311.     procedure ShowAboutBox;
  312.     property OleObject: Variant read GetOleObject;
  313.     property TabStop default True;
  314.   end;
  315.  
  316.   EOleCtrlError = class(Exception);
  317.  
  318. function FontToOleFont(Font: TFont): Variant;
  319. procedure OleFontToFont(const OleFont: Variant; Font: TFont);
  320.  
  321. implementation
  322.  
  323. uses OleConst;
  324.  
  325. {$J+}
  326.  
  327. const
  328.   OCM_BASE = $2000;
  329.  
  330. { Control flags }
  331.  
  332. const
  333.   cfBackColor = $00000001;
  334.   cfForeColor = $00000002;
  335.   cfFont      = $00000004;
  336.   cfEnabled   = $00000008;
  337.   cfCaption   = $00000010;
  338.   cfText      = $00000020;
  339.  
  340. type
  341.  
  342.   PDispInfo = ^TDispInfo;
  343.   TDispInfo = packed record
  344.     DispID: TDispID;
  345.     ResType: Byte;
  346.     CallDesc: TCallDesc;
  347.   end;
  348.  
  349.   TArgKind = (akDWord, akSingle, akDouble);
  350.  
  351.   PEventArg = ^TEventArg;
  352.   TEventArg = record
  353.     Kind: TArgKind;
  354.     Data: array[0..1] of Integer;
  355.   end;
  356.  
  357.   TEventInfo = record
  358.     Method: TMethod;
  359.     Sender: TObject;
  360.     ArgCount: Integer;
  361.     Args: array[0..MaxDispArgs - 1] of TEventArg;
  362.   end;
  363.  
  364. { Private variables }
  365.  
  366. var
  367.   PixPerInch: TPoint;
  368.  
  369. { Release an object reference }
  370.  
  371. procedure ReleaseObject(var Obj);
  372. begin
  373.   if IUnknown(Obj) <> nil then
  374.   begin
  375.     IUnknown(Obj).Release;
  376.     IUnknown(Obj) := nil;
  377.   end;
  378. end;
  379.  
  380. { Connect an IConnectionPoint interface }
  381.  
  382. procedure InterfaceConnect(Source: IUnknown; const IID: TIID;
  383.   Sink: IUnknown; var Connection: Longint);
  384. var
  385.   CPC: IConnectionPointContainer;
  386.   CP: IConnectionPoint;
  387. begin
  388.   Connection := 0;
  389.   if Source.QueryInterface(IID_IConnectionPointContainer, CPC) >= 0 then
  390.   begin
  391.     if CPC.FindConnectionPoint(IID, CP) >= 0 then
  392.     begin
  393.       CP.Advise(Sink, Connection);
  394.       CP.Release;
  395.     end;
  396.     CPC.Release;
  397.   end;
  398. end;
  399.  
  400. { Disconnect an IConnectionPoint interface }
  401.  
  402. procedure InterfaceDisconnect(Source: IUnknown; const IID: TIID;
  403.   var Connection: Longint);
  404. var
  405.   CPC: IConnectionPointContainer;
  406.   CP: IConnectionPoint;
  407. begin
  408.   if Connection <> 0 then
  409.     if Source.QueryInterface(IID_IConnectionPointContainer, CPC) >= 0 then
  410.     begin
  411.       if CPC.FindConnectionPoint(IID, CP) >= 0 then
  412.       begin
  413.         if CP.Unadvise(Connection) >= 0 then Connection := 0;
  414.         CP.Release;
  415.       end;
  416.       CPC.Release;
  417.     end;
  418. end;
  419.  
  420. function FontToOleFont(Font: TFont): Variant;
  421. var
  422.   FontDesc: TFontDesc;
  423.   FontName: array[0..63] of WideChar;
  424. begin
  425.   StringToWideChar(Font.Name, FontName, SizeOf(FontName));
  426.   with FontDesc do
  427.   begin
  428.     cbSizeOfStruct := SizeOf(FontDesc);
  429.     lpstrName := FontName;
  430.     cySize := Font.Size * 10000;
  431.     if fsBold in Font.Style then sWeight := 700 else sWeight := 400;
  432.     sCharset := DEFAULT_CHARSET;
  433.     fItalic := fsItalic in Font.Style;
  434.     fUnderline := fsUnderline in Font.Style;
  435.     fStrikethrough := fsStrikeout in Font.Style;
  436.   end;
  437.   VarClear(Result);
  438.   OleCheck(OleCreateFontIndirect(FontDesc, IID_IFontDisp,
  439.     TVarData(Result).VDispatch));
  440.   TVarData(Result).VType := varDispatch;
  441. end;
  442.  
  443. procedure OleFontToFont(const OleFont: Variant; Font: TFont);
  444. var
  445.   TempFont: TFont;
  446.   Style: TFontStyles;
  447. begin
  448.   TempFont := TFont.Create;
  449.   try
  450.     TempFont.Assign(Font);
  451.     TempFont.Name := OleFont.Name;
  452.     TempFont.Size := OleFont.Size;
  453.     Style := [];
  454.     if OleFont.Bold then Include(Style, fsBold);
  455.     if OleFont.Italic then Include(Style, fsItalic);
  456.     if OleFont.Underline then Include(Style, fsUnderline);
  457.     if OleFont.Strikethrough then Include(Style, fsStrikeout);
  458.     TempFont.Style := Style;
  459.     Font.Assign(TempFont);
  460.   finally
  461.     TempFont.Free;
  462.   end;
  463. end;
  464.  
  465. function StringToVarOleStr(const S: string): Variant;
  466. begin
  467.   VarClear(Result);
  468.   TVarData(Result).VOleStr := StringToOleStr(S);
  469.   TVarData(Result).VType := varOleStr;
  470. end;
  471.  
  472. { TOleClientSite }
  473.  
  474. constructor TOleClientSite.Create(Control: TOleControl);
  475. begin
  476.   FControl := Control;
  477. end;
  478.  
  479. function TOleClientSite.QueryInterface(const iid: TIID; var obj): HResult;
  480. begin
  481.   Result := FControl.QueryInterface(iid, obj);
  482. end;
  483.  
  484. function TOleClientSite.AddRef: Longint;
  485. begin
  486.   Result := FControl.AddRef;
  487. end;
  488.  
  489. function TOleClientSite.Release: Longint;
  490. begin
  491.   Result := FControl.Release;
  492. end;
  493.  
  494. function TOleClientSite.SaveObject: HResult;
  495. begin
  496.   Result := S_OK;
  497. end;
  498.  
  499. function TOleClientSite.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  500.   var mk: IMoniker): HResult;
  501. begin
  502.   mk := nil;
  503.   Result := E_NOTIMPL;
  504. end;
  505.  
  506. function TOleClientSite.GetContainer(var container: IOleContainer): HResult;
  507. begin
  508.   container := nil;
  509.   Result := E_NOTIMPL;
  510. end;
  511.  
  512. function TOleClientSite.ShowObject: HResult;
  513. begin
  514.   FControl.HookControlWndProc;
  515.   Result := S_OK;
  516. end;
  517.  
  518. function TOleClientSite.OnShowWindow(fShow: BOOL): HResult;
  519. begin
  520.   Result := S_OK;
  521. end;
  522.  
  523. function TOleClientSite.RequestNewObjectLayout: HResult;
  524. begin
  525.   Result := E_NOTIMPL;
  526. end;
  527.  
  528. { TOleControlSite }
  529.  
  530. constructor TOleControlSite.Create(Control: TOleControl);
  531. begin
  532.   FControl := Control;
  533. end;
  534.  
  535. function TOleControlSite.QueryInterface(const iid: TIID; var obj): HResult;
  536. begin
  537.   Result := FControl.QueryInterface(iid, obj);
  538. end;
  539.  
  540. function TOleControlSite.AddRef: Longint;
  541. begin
  542.   Result := FControl.AddRef;
  543. end;
  544.  
  545. function TOleControlSite.Release: Longint;
  546. begin
  547.   Result := FControl.Release;
  548. end;
  549.  
  550. function TOleControlSite.OnControlInfoChanged: HResult;
  551. begin
  552.   Result := E_NOTIMPL;
  553. end;
  554.  
  555. function TOleControlSite.LockInPlaceActive(fLock: BOOL): HResult;
  556. begin
  557.   Result := E_NOTIMPL;
  558. end;
  559.  
  560. function TOleControlSite.GetExtendedControl(var disp: IDispatch): HResult;
  561. begin
  562.   disp := nil;
  563.   Result := E_NOTIMPL;
  564. end;
  565.  
  566. function TOleControlSite.TransformCoords(var ptlHimetric: TPoint;
  567.   var ptfContainer: TPointF; flags: Longint): HResult;
  568. begin
  569.   if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then
  570.   begin
  571.     ptfContainer.X := MulDiv(ptlHimetric.X, PixPerInch.X, 2540);
  572.     ptfContainer.Y := MulDiv(ptlHimetric.Y, PixPerInch.Y, 2540);
  573.   end else
  574.   begin
  575.     ptlHimetric.X := Round(ptfContainer.X * 2540 / PixPerInch.X);
  576.     ptlHimetric.Y := Round(ptfContainer.Y * 2540 / PixPerInch.Y);
  577.   end;
  578.   Result := S_OK;
  579. end;
  580.  
  581. function TOleControlSite.TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;
  582. begin
  583.   Result := E_NOTIMPL;
  584. end;
  585.  
  586. function TOleControlSite.OnFocus(fGotFocus: BOOL): HResult;
  587. begin
  588.   Result := E_NOTIMPL;
  589. end;
  590.  
  591. function TOleControlSite.ShowPropertyFrame: HResult;
  592. begin
  593.   Result := E_NOTIMPL;
  594. end;
  595.  
  596. { TOleInPlaceSite }
  597.  
  598. constructor TOleInPlaceSite.Create(Control: TOleControl);
  599. begin
  600.   FControl := Control;
  601. end;
  602.  
  603. function TOleInPlaceSite.QueryInterface(const iid: TIID; var obj): HResult;
  604. begin
  605.   Result := FControl.QueryInterface(iid, obj);
  606. end;
  607.  
  608. function TOleInPlaceSite.AddRef: Longint;
  609. begin
  610.   Result := FControl.AddRef;
  611. end;
  612.  
  613. function TOleInPlaceSite.Release: Longint;
  614. begin
  615.   Result := FControl.Release;
  616. end;
  617.  
  618. function TOleInPlaceSite.GetWindow(var wnd: HWnd): HResult;
  619. begin
  620.   if FControl.Parent <> nil then
  621.   begin
  622.     wnd := FControl.Parent.Handle;
  623.     Result := S_OK;
  624.   end else
  625.   begin
  626.     wnd := 0;
  627.     Result := E_FAIL;
  628.   end;
  629. end;
  630.  
  631. function TOleInPlaceSite.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  632. begin
  633.   Result := S_OK;
  634. end;
  635.  
  636. function TOleInPlaceSite.CanInPlaceActivate: HResult;
  637. begin
  638.   Result := S_OK;
  639. end;
  640.  
  641. function TOleInPlaceSite.OnInPlaceActivate: HResult;
  642. begin
  643.   with FControl do
  644.   begin
  645.     FOleObject.QueryInterface(IID_IOleInPlaceObject, FOleInPlaceObject);
  646.     FOleObject.QueryInterface(IID_IOleInPlaceActiveObject, FOleInPlaceActiveObject);
  647.   end;
  648.   Result := S_OK;
  649. end;
  650.  
  651. function TOleInPlaceSite.OnUIActivate: HResult;
  652. begin
  653.   FControl.SetUIActive(True);
  654.   Result := S_OK;
  655. end;
  656.  
  657. function TOleInPlaceSite.GetWindowContext(var frame: IOleInPlaceFrame;
  658.   var doc: IOleInPlaceUIWindow; var rcPosRect: TRect;
  659.   var rcClipRect: TRect; var frameInfo: TOleInPlaceFrameInfo): HResult;
  660. begin
  661.   with FControl do
  662.   begin
  663.     frame := FOleInPlaceFrame;
  664.     FOleInPlaceFrame.AddRef;
  665.     doc := nil;
  666.     rcPosRect := BoundsRect;
  667.     SetRect(rcClipRect, 0, 0, 32767, 32767);
  668.     with frameInfo do
  669.     begin
  670.       fMDIApp := False;
  671.       hWndFrame := GetParentForm(FControl).Handle;
  672.       hAccel := 0;
  673.       cAccelEntries := 0;
  674.     end;
  675.   end;
  676.   Result := S_OK;
  677. end;
  678.  
  679. function TOleInPlaceSite.Scroll(const scrollExtent: TPoint): HResult;
  680. begin
  681.   Result := E_NOTIMPL;
  682. end;
  683.  
  684. function TOleInPlaceSite.OnUIDeactivate(fUndoable: BOOL): HResult;
  685. begin
  686.   FControl.FOleInPlaceFrame.SetMenu(0, 0, 0);
  687.   FControl.SetUIActive(False);
  688.   Result := S_OK;
  689. end;
  690.  
  691. function TOleInPlaceSite.OnInPlaceDeactivate: HResult;
  692. begin
  693.   ReleaseObject(FControl.FOleInPlaceActiveObject);
  694.   ReleaseObject(FControl.FOleInPlaceObject);
  695.   Result := S_OK;
  696. end;
  697.  
  698. function TOleInPlaceSite.DiscardUndoState: HResult;
  699. begin
  700.   Result := E_NOTIMPL;
  701. end;
  702.  
  703. function TOleInPlaceSite.DeactivateAndUndo: HResult;
  704. begin
  705.   FControl.FOleInPlaceObject.UIDeactivate;
  706.   Result := S_OK;
  707. end;
  708.  
  709. function TOleInPlaceSite.OnPosRectChange(const rcPosRect: TRect): HResult;
  710. begin
  711.   FControl.FOleInPlaceObject.SetObjectRects(rcPosRect,
  712.     Rect(0, 0, 32767, 32767));
  713.   Result := S_OK;
  714. end;
  715.  
  716. { TOleInPlaceFrame }
  717.  
  718. constructor TOleInPlaceFrame.Create(Control: TOleControl);
  719. begin
  720.   FControl := Control;
  721. end;
  722.  
  723. function TOleInPlaceFrame.QueryInterface(const iid: TIID; var obj): HResult;
  724. begin
  725.   if IsEqualIID(iid, IID_IUnknown) or
  726.     IsEqualIID(iid, IID_IOleInPlaceFrame) then
  727.   begin
  728.     Pointer(obj) := Self;
  729.     AddRef;
  730.     Result := S_OK;
  731.   end else
  732.   begin
  733.     Pointer(obj) := nil;
  734.     Result := E_NOINTERFACE;
  735.   end;
  736. end;
  737.  
  738. function TOleInPlaceFrame.AddRef: Longint;
  739. begin
  740.   Result := FControl.AddRef;
  741. end;
  742.  
  743. function TOleInPlaceFrame.Release: Longint;
  744. begin
  745.   Result := FControl.Release;
  746. end;
  747.  
  748. function TOleInPlaceFrame.GetWindow(var wnd: HWnd): HResult;
  749. begin
  750.   wnd := GetParentForm(FControl).Handle;
  751.   Result := S_OK;
  752. end;
  753.  
  754. function TOleInPlaceFrame.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  755. begin
  756.   Result := S_OK;
  757. end;
  758.  
  759. function TOleInPlaceFrame.GetBorder(var rectBorder: TRect): HResult;
  760. begin
  761.   Result := INPLACE_E_NOTOOLSPACE;
  762. end;
  763.  
  764. function TOleInPlaceFrame.RequestBorderSpace(const borderwidths: TRect): HResult;
  765. begin
  766.   Result := INPLACE_E_NOTOOLSPACE;
  767. end;
  768.  
  769. function TOleInPlaceFrame.SetBorderSpace(pborderwidths: PRect): HResult;
  770. begin
  771.   Result := E_NOTIMPL;
  772. end;
  773.  
  774. function TOleInPlaceFrame.SetActiveObject(activeObject: IOleInPlaceActiveObject;
  775.   pszObjName: POleStr): HResult;
  776. begin
  777.   Result := S_OK;
  778. end;
  779.  
  780. function TOleInPlaceFrame.InsertMenus(hmenuShared: HMenu;
  781.   var menuWidths: TOleMenuGroupWidths): HResult;
  782. var
  783.   Menu: TMainMenu;
  784. begin
  785.   Menu := FControl.GetMainMenu;
  786.   if Menu <> nil then
  787.     Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);
  788.   Result := S_OK;
  789. end;
  790.  
  791. function TOleInPlaceFrame.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  792.   hwndActiveObject: HWnd): HResult;
  793. var
  794.   Menu: TMainMenu;
  795. begin
  796.   Menu := FControl.GetMainMenu;
  797.   Result := S_OK;
  798.   if Menu <> nil then
  799.   begin
  800.     Menu.SetOle2MenuHandle(hmenuShared);
  801.     Result := OleSetMenuDescriptor(holemenu, Menu.WindowHandle,
  802.       hwndActiveObject, nil, nil);
  803.   end;
  804. end;
  805.  
  806. function TOleInPlaceFrame.RemoveMenus(hmenuShared: HMenu): HResult;
  807. begin
  808.   while GetMenuItemCount(hmenuShared) > 0 do
  809.     RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
  810.   Result := S_OK;
  811. end;
  812.  
  813. function TOleInPlaceFrame.SetStatusText(pszStatusText: POleStr): HResult;
  814. begin
  815.   Result := S_OK;
  816. end;
  817.  
  818. function TOleInPlaceFrame.EnableModeless(fEnable: BOOL): HResult;
  819. begin
  820.   Result := S_OK;
  821. end;
  822.  
  823. function TOleInPlaceFrame.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
  824. begin
  825.   Result := S_FALSE;
  826. end;
  827.  
  828. { TAmbientDispatch }
  829.  
  830. constructor TAmbientDispatch.Create(Control: TOleControl);
  831. begin
  832.   FControl := Control;
  833. end;
  834.  
  835. function TAmbientDispatch.QueryInterface(const iid: TIID; var obj): HResult;
  836. begin
  837.   Result := FControl.QueryInterface(iid, obj);
  838. end;
  839.  
  840. function TAmbientDispatch.AddRef: Longint;
  841. begin
  842.   Result := FControl.AddRef;
  843. end;
  844.  
  845. function TAmbientDispatch.Release: Longint;
  846. begin
  847.   Result := FControl.Release;
  848. end;
  849.  
  850. function TAmbientDispatch.GetTypeInfoCount(var ctinfo: Integer): HResult;
  851. begin
  852.   ctinfo := 0;
  853.   Result := S_OK;
  854. end;
  855.  
  856. function TAmbientDispatch.GetTypeInfo(itinfo: Integer; lcid: TLCID;
  857.   var tinfo: ITypeInfo): HResult;
  858. begin
  859.   tinfo := nil;
  860.   Result := E_NOTIMPL;
  861. end;
  862.  
  863. function TAmbientDispatch.GetIDsOfNames(const iid: TIID;
  864.   rgszNames: POleStrList; cNames: Integer; lcid: TLCID;
  865.   rgdispid: PDispIDList): HResult;
  866. begin
  867.   Result := E_NOTIMPL;
  868. end;
  869.  
  870. function TAmbientDispatch.Invoke(dispIDMember: TDispID; const iid: TIID;
  871.   lcid: TLCID; flags: Word; var dispParams: TDispParams; varResult: PVariant;
  872.   excepInfo: PExcepInfo; argErr: PInteger): HResult;
  873. begin
  874.   if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
  875.   begin
  876.     Result := S_OK;
  877.     with FControl do
  878.       case DispIDMember of
  879.         DISPID_AMBIENT_BACKCOLOR:
  880.           VarResult^ := Color;
  881.         DISPID_AMBIENT_DISPLAYNAME:
  882.           VarResult^ := StringToVarOleStr(Name);
  883.         DISPID_AMBIENT_FONT:
  884.           if (Parent <> nil) and ParentFont then
  885.             VarResult^ := FontToOleFont(TOleControl(Parent).Font) else
  886.             Result := DISP_E_MEMBERNOTFOUND;
  887.         DISPID_AMBIENT_FORECOLOR:
  888.           VarResult^ := Font.Color;
  889.         DISPID_AMBIENT_LOCALEID:
  890.           VarResult^ := GetUserDefaultLCID;
  891.         DISPID_AMBIENT_MESSAGEREFLECT:
  892.           VarResult^ := True;
  893.         DISPID_AMBIENT_USERMODE:
  894.           VarResult^ := not (csDesigning in ComponentState);
  895.         DISPID_AMBIENT_UIDEAD:
  896.           VarResult^ := csDesigning in ComponentState;
  897.         DISPID_AMBIENT_SHOWGRABHANDLES:
  898.           VarResult^ := False;
  899.         DISPID_AMBIENT_SHOWHATCHING:
  900.           VarResult^ := False;
  901.         DISPID_AMBIENT_SUPPORTSMNEMONICS:
  902.           VarResult^ := True;
  903.         DISPID_AMBIENT_AUTOCLIP:
  904.           VarResult^ := True;
  905.       else
  906.         Result := DISP_E_MEMBERNOTFOUND;
  907.       end;
  908.   end else
  909.     Result := DISP_E_MEMBERNOTFOUND;
  910. end;
  911.  
  912. { TEventDispatch }
  913.  
  914. constructor TEventDispatch.Create(Control: TOleControl);
  915. begin
  916.   FControl := Control;
  917. end;
  918.  
  919. function TEventDispatch.QueryInterface(const iid: TIID; var obj): HResult;
  920. begin
  921.   Result := FControl.QueryInterface(iid, obj);
  922. end;
  923.  
  924. function TEventDispatch.AddRef: Longint;
  925. begin
  926.   Result := FControl.AddRef;
  927. end;
  928.  
  929. function TEventDispatch.Release: Longint;
  930. begin
  931.   Result := FControl.Release;
  932. end;
  933.  
  934. function TEventDispatch.GetTypeInfoCount(var ctinfo: Integer): HResult;
  935. begin
  936.   ctinfo := 0;
  937.   Result := S_OK;
  938. end;
  939.  
  940. function TEventDispatch.GetTypeInfo(itinfo: Integer; lcid: TLCID;
  941.   var tinfo: ITypeInfo): HResult;
  942. begin
  943.   tinfo := nil;
  944.   Result := E_NOTIMPL;
  945. end;
  946.  
  947. function TEventDispatch.GetIDsOfNames(const iid: TIID;
  948.   rgszNames: POleStrList; cNames: Integer; lcid: TLCID;
  949.   rgdispid: PDispIDList): HResult;
  950. begin
  951.   Result := E_NOTIMPL;
  952. end;
  953.  
  954. function TEventDispatch.Invoke(dispIDMember: TDispID; const iid: TIID;
  955.   lcid: TLCID; flags: Word; var dispParams: TDispParams; varResult: PVariant;
  956.   excepInfo: PExcepInfo; argErr: PInteger): HResult;
  957. begin
  958.   if (dispIDMember >= DISPID_MOUSEUP) and (dispIDMember <= DISPID_CLICK) then
  959.     FControl.StandardEvent(dispIDMember, dispParams) else
  960.     FControl.InvokeEvent(dispIDMember, dispParams);
  961.   Result := S_OK;
  962. end;
  963.  
  964. { TPropertyNotifySink }
  965.  
  966. constructor TPropertyNotifySink.Create(Control: TOleControl);
  967. begin
  968.   FControl := Control;
  969. end;
  970.  
  971. function TPropertyNotifySink.QueryInterface(const iid: TIID; var obj): HResult;
  972. begin
  973.   Result := FControl.QueryInterface(iid, obj);
  974. end;
  975.  
  976. function TPropertyNotifySink.AddRef: Longint;
  977. begin
  978.   Result := FControl.AddRef;
  979. end;
  980.  
  981. function TPropertyNotifySink.Release: Longint;
  982. begin
  983.   Result := FControl.Release;
  984. end;
  985.  
  986. function TPropertyNotifySink.OnChanged(dispid: TDispID): HResult;
  987. begin
  988.   with FControl do
  989.     case dispid of
  990.       DISPID_BACKCOLOR:
  991.         if not FUpdatingColor then
  992.         begin
  993.           FUpdatingColor := True;
  994.           try
  995.             Color := GetIntegerProp(DISPID_BACKCOLOR);
  996.           finally
  997.             FUpdatingColor := False;
  998.           end;
  999.         end;
  1000.       DISPID_ENABLED:
  1001.         if not FUpdatingEnabled then
  1002.         begin
  1003.           FUpdatingEnabled := True;
  1004.           try
  1005.             Enabled := GetOleBoolProp(DISPID_ENABLED);
  1006.           finally
  1007.             FUpdatingEnabled := False;
  1008.           end;
  1009.         end;
  1010.       DISPID_FONT:
  1011.         if not FUpdatingFont then
  1012.         begin
  1013.           FUpdatingFont := True;
  1014.           try
  1015.             OleFontToFont(GetVariantProp(DISPID_FONT), Font);
  1016.           finally
  1017.             FUpdatingFont := False;
  1018.           end;
  1019.         end;
  1020.       DISPID_FORECOLOR:
  1021.         if not FUpdatingFont then
  1022.         begin
  1023.           FUpdatingFont := True;
  1024.           try
  1025.             Font.Color := GetIntegerProp(DISPID_FORECOLOR);
  1026.           finally
  1027.             FUpdatingFont := False;
  1028.           end;
  1029.         end;
  1030.     end;
  1031.   Result := S_OK;
  1032. end;
  1033.  
  1034. function TPropertyNotifySink.OnRequestEdit(dispid: TDispID): HResult;
  1035. begin
  1036.   Result := S_OK;
  1037. end;
  1038.  
  1039. { TSimpleFrameSite }
  1040.  
  1041. constructor TSimpleFrameSite.Create(Control: TOleControl);
  1042. begin
  1043.   FControl := Control;
  1044. end;
  1045.  
  1046. function TSimpleFrameSite.QueryInterface(const iid: TIID; var obj): HResult;
  1047. begin
  1048.   Result := FControl.QueryInterface(iid, obj);
  1049. end;
  1050.  
  1051. function TSimpleFrameSite.AddRef: Longint;
  1052. begin
  1053.   Result := FControl.AddRef;
  1054. end;
  1055.  
  1056. function TSimpleFrameSite.Release: Longint;
  1057. begin
  1058.   Result := FControl.Release;
  1059. end;
  1060.  
  1061. function TSimpleFrameSite.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  1062.   var res: Integer; var Cookie: Longint): HResult;
  1063. begin
  1064.   Result := S_OK;
  1065. end;
  1066.  
  1067. function TSimpleFrameSite.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
  1068.   var res: Integer; Cookie: Longint): HResult;
  1069. begin
  1070.   Result := S_OK;
  1071. end;
  1072.  
  1073. { TEnumPropDesc }
  1074.  
  1075. constructor TEnumPropDesc.Create(DispID, ValueCount: Integer;
  1076.   TypeInfo: ITypeInfo);
  1077. var
  1078.   I: Integer;
  1079.   VarDesc: PVarDesc;
  1080.   BStr: TBStr;
  1081. begin
  1082.   FDispID := DispID;
  1083.   FValueCount := ValueCount;
  1084.   FValues := AllocMem(ValueCount * SizeOf(TEnumValue));
  1085.   for I := 0 to ValueCount - 1 do
  1086.   begin
  1087.     OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  1088.     try
  1089.       OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @BStr,
  1090.         nil, nil, nil));
  1091.       try
  1092.         with FValues^[I] do
  1093.         begin
  1094.           Value := TVarData(VarDesc^.lpVarValue^).VInteger;
  1095.           OleStrToStrVar(BStr, Ident);
  1096.           while (Length(Ident) > 1) and (Ident[1] = '_') do
  1097.             Delete(Ident, 1, 1);
  1098.         end;
  1099.       finally
  1100.         SysFreeString(BStr);
  1101.       end;
  1102.     finally
  1103.       TypeInfo.ReleaseVarDesc(VarDesc);
  1104.     end;
  1105.   end;
  1106. end;
  1107.  
  1108. destructor TEnumPropDesc.Destroy;
  1109. begin
  1110.   if FValues <> nil then
  1111.   begin
  1112.     Finalize(FValues^[0], FValueCount);
  1113.     FreeMem(FValues, FValueCount * SizeOf(TEnumValue));
  1114.   end;
  1115. end;
  1116.  
  1117. procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc);
  1118. var
  1119.   I: Integer;
  1120. begin
  1121.   for I := 0 to FValueCount - 1 do
  1122.     with FValues^[I] do Proc(Format('%d - %s', [Value, Ident]));
  1123. end;
  1124.  
  1125. function TEnumPropDesc.StringToValue(const S: string): Integer;
  1126. var
  1127.   I: Integer;
  1128. begin
  1129.   I := 1;
  1130.   while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I);
  1131.   if I > 1 then
  1132.   begin
  1133.     Result := StrToInt(Copy(S, 1, I - 1));
  1134.     for I := 0 to FValueCount - 1 do
  1135.       if Result = FValues^[I].Value then Exit;
  1136.   end else
  1137.     for I := 0 to FValueCount - 1 do
  1138.       with FValues^[I] do
  1139.         if AnsiCompareText(S, Ident) = 0 then
  1140.         begin
  1141.           Result := Value;
  1142.           Exit;
  1143.         end;
  1144.   raise EOleError.CreateResFmt(SBadPropValue, [S]);
  1145. end;
  1146.  
  1147. function TEnumPropDesc.ValueToString(V: Integer): string;
  1148. var
  1149.   I: Integer;
  1150. begin
  1151.   for I := 0 to FValueCount - 1 do
  1152.     with FValues^[I] do
  1153.       if V = Value then
  1154.       begin
  1155.         Result := Format('%d - %s', [Value, Ident]);
  1156.         Exit;
  1157.       end;
  1158.   Result := IntToStr(V);
  1159. end;
  1160.  
  1161. { TOleControl }
  1162.  
  1163. constructor TOleControl.Create(AOwner: TComponent);
  1164. var
  1165.   W, H: Integer;
  1166.   Extent: TPoint;
  1167. begin
  1168.   inherited Create(AOwner);
  1169.   Include(FComponentStyle, csCheckPropAvail);
  1170.   InitControlData;
  1171.   Inc(FControlData^.InstanceCount);
  1172.   FOleClientSite := TOleClientSite.Create(Self);
  1173.   FOleControlSite := TOleControlSite.Create(Self);
  1174.   FOleInPlaceSite := TOleInPlaceSite.Create(Self);
  1175.   FOleInPlaceFrame := TOleInPlaceFrame.Create(Self);
  1176.   FAmbientDispatch := TAmbientDispatch.Create(Self);
  1177.   FEventDispatch := TEventDispatch.Create(Self);
  1178.   FPropertyNotifySink := TPropertyNotifySink.Create(Self);
  1179.   FSimpleFrameSite := TSimpleFrameSite.Create(Self);
  1180.   CreateInstance;
  1181.   OleCheck(FOleObject.SetClientSite(FOleClientSite));
  1182.   OleCheck(FOleObject.QueryInterface(IID_IPersistStreamInit,
  1183.     FPersistStream));
  1184.   OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus));
  1185.   OleCheck(FOleObject.GetExtent(DVASPECT_CONTENT, Extent));
  1186.   W := MulDiv(Extent.X, PixPerInch.X, 2540);
  1187.   H := MulDiv(Extent.Y, PixPerInch.Y, 2540);
  1188.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
  1189.   begin
  1190.     Visible := False;
  1191.     if W > 32 then W := 32;
  1192.     if H > 32 then H := 32;
  1193.   end;
  1194.   inherited SetBounds(Left, Top, W, H);
  1195.   if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
  1196.     ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else
  1197.     ControlStyle := [csDoubleClicks, csNoStdEvents];
  1198.   TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or
  1199.     OLEMISC_NOUIACTIVATE) = 0;
  1200. end;
  1201.  
  1202. destructor TOleControl.Destroy;
  1203. begin
  1204.   if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
  1205.   DestroyControl;
  1206.   DestroyStorage;
  1207.   ReleaseObject(FPersistStream);
  1208.   if FOleObject <> nil then FOleObject.SetClientSite(nil);
  1209.   ReleaseObject(FOleObject);
  1210.   FSimpleFrameSite.Free;
  1211.   FPropertyNotifySink.Free;
  1212.   FEventDispatch.Free;
  1213.   FAmbientDispatch.Free;
  1214.   FOleInPlaceFrame.Free;
  1215.   FOleInPlaceSite.Free;
  1216.   FOleControlSite.Free;
  1217.   FOleClientSite.Free;
  1218.   Dec(FControlData^.InstanceCount);
  1219.   if FControlData^.InstanceCount = 0 then DestroyEnumPropDescs;
  1220.   inherited Destroy;
  1221. end;
  1222.  
  1223. function TOleControl.AddRef: Longint;
  1224. begin
  1225.   Inc(FRefCount);
  1226.   Result := FRefCount;
  1227. end;
  1228.  
  1229. procedure TOleControl.BrowseProperties;
  1230. begin
  1231.   DoObjectVerb(OLEIVERB_PROPERTIES);
  1232. end;
  1233.  
  1234. procedure TOleControl.CreateControl;
  1235. var
  1236.   Stream: IStream;
  1237. begin
  1238.   if FOleControl = nil then
  1239.     try
  1240.       if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else
  1241.       begin
  1242.         OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
  1243.         try
  1244.           OleCheck(FPersistStream.Load(Stream));
  1245.         finally
  1246.           Stream.Release;
  1247.         end;
  1248.         DestroyStorage;
  1249.       end;
  1250.       OleCheck(FOleObject.QueryInterface(IID_IOleControl, FOleControl));
  1251.       OleCheck(FOleObject.QueryInterface(IID_IDispatch, FControlDispatch));
  1252.       FOleObject.QueryInterface(IID_IPerPropertyBrowsing, FPropBrowsing);
  1253.       InterfaceConnect(FOleObject, IID_IPropertyNotifySink,
  1254.         FPropertyNotifySink, FPropConnection);
  1255.       InterfaceConnect(FOleObject, FControlData^.EventIID,
  1256.         FEventDispatch, FEventsConnection);
  1257.       if FControlData^.Flags and cfBackColor <> 0 then
  1258.         FPropertyNotifySink.OnChanged(DISPID_BACKCOLOR);
  1259.       if FControlData^.Flags and cfEnabled <> 0 then
  1260.         FPropertyNotifySink.OnChanged(DISPID_ENABLED);
  1261.       if FControlData^.Flags and cfFont <> 0 then
  1262.         FPropertyNotifySink.OnChanged(DISPID_FONT);
  1263.       if FControlData^.Flags and cfForeColor <> 0 then
  1264.         FPropertyNotifySink.OnChanged(DISPID_FORECOLOR);
  1265.       FOleObject.SetExtent(DVASPECT_CONTENT, Point(
  1266.         MulDiv(Width, 2540, PixPerInch.X),
  1267.         MulDiv(Height, 2540, PixPerInch.Y)));
  1268.     except
  1269.       DestroyControl;
  1270.       raise;
  1271.     end;
  1272. end;
  1273.  
  1274. procedure TOleControl.CreateEnumPropDescs;
  1275. var
  1276.   I: Integer;
  1277.   TypeInfo, RefInfo: ITypeInfo;
  1278.   TypeAttr, RefAttr: PTypeAttr;
  1279.   VarDesc: PVarDesc;
  1280. begin
  1281.   CreateControl;
  1282.   FControlData^.EnumPropDescs := TList.Create;
  1283.   try
  1284.     OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
  1285.     try
  1286.       OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  1287.       try
  1288.         for I := 0 to TypeAttr^.cVars - 1 do
  1289.         begin
  1290.           OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  1291.           try
  1292.             if VarDesc^.elemdescVar.tdesc.vt = VT_USERDEFINED then
  1293.             begin
  1294.               OleCheck(TypeInfo.GetRefTypeInfo(
  1295.                 VarDesc^.elemdescVar.tdesc.hreftype, RefInfo));
  1296.               try
  1297.                 OleCheck(RefInfo.GetTypeAttr(RefAttr));
  1298.                 try
  1299.                   if RefAttr^.typekind = TKIND_ENUM then
  1300.                     FControlData^.EnumPropDescs.Expand.Add(
  1301.                       TEnumPropDesc.Create(VarDesc^.memid,
  1302.                       RefAttr^.cVars, RefInfo));
  1303.                 finally
  1304.                   RefInfo.ReleaseTypeAttr(RefAttr);
  1305.                 end;
  1306.               finally
  1307.                 RefInfo.Release;
  1308.               end;
  1309.             end;
  1310.           finally
  1311.             TypeInfo.ReleaseVarDesc(VarDesc);
  1312.           end;
  1313.         end;
  1314.       finally
  1315.         TypeInfo.ReleaseTypeAttr(TypeAttr);
  1316.       end;
  1317.     finally
  1318.       TypeInfo.Release;
  1319.     end;
  1320.   except
  1321.     DestroyEnumPropDescs;
  1322.     raise;
  1323.   end;
  1324. end;
  1325.  
  1326. procedure TOleControl.CreateInstance;
  1327. var
  1328.   ClassFactory2: IClassFactory2;
  1329.   LicKeyStr: TBStr;
  1330.  
  1331.   procedure LicenseCheck(Status: HResult; Ident: Integer);
  1332.   begin
  1333.     if Status = CLASS_E_NOTLICENSED then
  1334.       raise EOleError.CreateResFmt(Ident, [ClassName]);
  1335.     OleCheck(Status);
  1336.   end;
  1337.  
  1338. begin
  1339.   if not (csDesigning in ComponentState) and
  1340.     (FControlData^.LicenseKey <> nil) then
  1341.   begin
  1342.     LicKeyStr := nil;
  1343.     OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
  1344.       CLSCTX_LOCAL_SERVER, nil, IID_IClassFactory2, ClassFactory2));
  1345.     try
  1346.       LicKeyStr := SysAllocString(FControlData^.LicenseKey);
  1347.       LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IID_IOleObject,
  1348.         LicKeyStr, FOleObject), SInvalidLicense);
  1349.     finally
  1350.       if LicKeyStr <> nil then SysFreeString(LicKeyStr);
  1351.       ClassFactory2.Release;
  1352.     end;
  1353.   end else
  1354.     LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
  1355.       CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IID_IOleObject,
  1356.       FOleObject), SNotLicensed);
  1357. end;
  1358.  
  1359. procedure TOleControl.CreateStorage;
  1360. var
  1361.   Stream: IStream;
  1362. begin
  1363.   DestroyStorage;
  1364.   FObjectData := GlobalAlloc(GMEM_MOVEABLE, 0);
  1365.   if FObjectData = 0 then OutOfMemoryError;
  1366.   try
  1367.     OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
  1368.     try
  1369.       OleCheck(FPersistStream.Save(Stream, True));
  1370.     finally
  1371.       Stream.Release;
  1372.     end;
  1373.   except
  1374.     DestroyStorage;
  1375.     raise;
  1376.   end;
  1377. end;
  1378.  
  1379. procedure TOleControl.CreateWnd;
  1380. begin
  1381.   CreateControl;
  1382.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  1383.   begin
  1384.     FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, FOleClientSite, 0,
  1385.       Parent.Handle, BoundsRect);
  1386.     if FOleInPlaceObject = nil then
  1387.       raise EOleError.CreateRes(SCannotActivate);
  1388.     HookControlWndProc;
  1389.     if not Visible and IsWindowVisible(Handle) then
  1390.       ShowWindow(Handle, SW_HIDE);
  1391.   end else
  1392.     inherited CreateWnd;
  1393. end;
  1394.  
  1395. procedure TOleControl.DefaultHandler(var Message);
  1396. begin
  1397.   if HandleAllocated then
  1398.     with TMessage(Message) do
  1399.     begin
  1400.       if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
  1401.         Msg := Msg - (CN_BASE - OCM_BASE);
  1402.       if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
  1403.       begin
  1404.         Result := CallWindowProc(DefWndProc, Handle, Msg, WParam, LParam);
  1405.         Exit;
  1406.       end;
  1407.     end;
  1408.   inherited DefaultHandler(Message);
  1409. end;
  1410.  
  1411. procedure TOleControl.DefineProperties(Filer: TFiler);
  1412. begin
  1413.   inherited DefineProperties(Filer);
  1414.   Filer.DefineBinaryProperty('ControlData', ReadData, WriteData, FOleObject <> nil);
  1415. end;
  1416.  
  1417. procedure TOleControl.DesignModified;
  1418. var
  1419.   Form: TForm;
  1420. begin
  1421.   Form := GetParentForm(Self);
  1422.   if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1423. end;
  1424.  
  1425. procedure TOleControl.DestroyControl;
  1426. begin
  1427.   InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
  1428.   InterfaceDisconnect(FOleObject, IID_IPropertyNotifySink, FPropConnection);
  1429.   ReleaseObject(FPropBrowsing);
  1430.   ReleaseObject(FControlDispatch);
  1431.   ReleaseObject(FOleControl);
  1432. end;
  1433.  
  1434. procedure TOleControl.DestroyEnumPropDescs;
  1435. var
  1436.   I: Integer;
  1437. begin
  1438.   with FControlData^ do
  1439.     if EnumPropDescs <> nil then
  1440.     begin
  1441.       for I := 0 to EnumPropDescs.Count - 1 do
  1442.         TEnumPropDesc(EnumPropDescs[I]).Free;
  1443.       EnumPropDescs.Free;
  1444.       EnumPropDescs := nil;
  1445.     end;
  1446. end;
  1447.  
  1448. procedure TOleControl.DestroyStorage;
  1449. begin
  1450.   if FObjectData <> 0 then
  1451.   begin
  1452.     GlobalFree(FObjectData);
  1453.     FObjectData := 0;
  1454.   end;
  1455. end;
  1456.  
  1457. procedure TOleControl.DestroyWindowHandle;
  1458. begin
  1459.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  1460.   begin
  1461.     SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(DefWndProc));
  1462.     if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
  1463.     WindowHandle := 0;
  1464.   end else
  1465.     inherited DestroyWindowHandle;
  1466. end;
  1467.  
  1468. procedure TOleControl.DoObjectVerb(Verb: Integer);
  1469. var
  1470.   ActiveWindow: HWnd;
  1471.   WindowList: Pointer;
  1472. begin
  1473.   CreateControl;
  1474.   ActiveWindow := GetActiveWindow;
  1475.   WindowList := DisableTaskWindows(0);
  1476.   try
  1477.     OleCheck(FOleObject.DoVerb(Verb, nil, FOleClientSite, 0,
  1478.       Parent.Handle, BoundsRect));
  1479.   finally
  1480.     EnableTaskWindows(WindowList);
  1481.     SetActiveWindow(ActiveWindow);
  1482.   end;
  1483.   if FPersistStream.IsDirty <> S_FALSE then DesignModified;
  1484. end;
  1485.  
  1486. function TOleControl.GetColorProp(Index: Integer): TColor;
  1487. begin
  1488.   Result := GetIntegerProp(Index);
  1489. end;
  1490.  
  1491. function TOleControl.GetCurrencyProp(Index: Integer): TCurrency;
  1492. var
  1493.   Temp: TVarData;
  1494. begin
  1495.   GetProperty(Index, Temp);
  1496.   Result := Temp.VCurrency;
  1497. end;
  1498.  
  1499. function TOleControl.GetDoubleProp(Index: Integer): Double;
  1500. var
  1501.   Temp: TVarData;
  1502. begin
  1503.   GetProperty(Index, Temp);
  1504.   Result := Temp.VDouble;
  1505. end;
  1506.  
  1507. function TOleControl.GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
  1508. var
  1509.   I: Integer;
  1510. begin
  1511.   with FControlData^ do
  1512.   begin
  1513.     if EnumPropDescs = nil then CreateEnumPropDescs;
  1514.     for I := 0 to EnumPropDescs.Count - 1 do
  1515.     begin
  1516.       Result := EnumPropDescs[I];
  1517.       if Result.FDispID = DispID then Exit;
  1518.     end;
  1519.     Result := nil;
  1520.   end;
  1521. end;
  1522.  
  1523. procedure TOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod);
  1524. asm
  1525.         PUSH    EBX
  1526.         PUSH    ESI
  1527.         PUSH    EDI
  1528.         MOV     EBX,EAX
  1529.         MOV     ESI,[EBX].TOleControl.FControlData
  1530.         MOV     EDI,[ESI].TControlData.EventCount
  1531.         MOV     ESI,[ESI].TControlData.EventDispIDs
  1532.         XOR     EAX,EAX
  1533.         JMP     @@1
  1534. @@0:    CMP     EDX,[ESI].Integer[EAX*4]
  1535.         JE      @@2
  1536.         INC     EAX
  1537. @@1:    CMP     EAX,EDI
  1538.         JNE     @@0
  1539.         XOR     EAX,EAX
  1540.         XOR     EDX,EDX
  1541.         JMP     @@3
  1542. @@2:    MOV     EDX,[EBX].TOleControl.FEvents[4][EAX*8].TMethod.Data
  1543.         MOV     EAX,[EBX].TOleControl.FEvents[4][EAX*8].TMethod.Code
  1544. @@3:    MOV     [ECX].TMethod.Code,EAX
  1545.         MOV     [ECX].TMethod.Data,EDX
  1546.         POP     EDI
  1547.         POP     ESI
  1548.         POP     EBX
  1549. end;
  1550.  
  1551. procedure Exchange(var A,B); register;
  1552. asm
  1553.   MOV   ECX, [EDX]
  1554.   XCHG  ECX, [EAX]
  1555.   MOV   [EDX], ECX
  1556. end;
  1557.  
  1558. { TOleControl.GetHelpContext:  Fetch the help file name and help context
  1559.   id of the given member (property, event, or method) of the Ole Control from
  1560.   the control's ITypeInfo interfaces.  GetHelpContext returns False if
  1561.   the member name is not found in the control's ITypeInfo.
  1562.   To obtain a help context for the entire control class, pass an empty
  1563.   string as the Member name.  }
  1564.  
  1565. function TOleControl.GetHelpContext(Member: String;
  1566.   var HelpCtx: Integer; var HelpFile: String): Boolean;
  1567. var
  1568.   ProvideClassInfo: IProvideClassInfo;
  1569.   TypeInfo: ITypeInfo;
  1570.   HlpFile: TBStr;
  1571.   ImplTypes, MemberID: Integer;
  1572.   TypeAttr: PTypeAttr;
  1573.  
  1574.   function Find(const MemberStr: string; var TypeInfo: ITypeInfo): Boolean;
  1575.   var
  1576.     Code: HResult;
  1577.     I, Flags: Integer;
  1578.     RefType: HRefType;
  1579.     Name: TBStr;
  1580.     Temp: ITypeInfo;
  1581.   begin
  1582.     Result := False;
  1583.     Name := StringToOleStr(Member);
  1584.     try
  1585.       I := 0;
  1586.       while (I < ImplTypes) do
  1587.       begin
  1588.         OleCheck(TypeInfo.GetImplTypeFlags(I, Flags));
  1589.         if Flags and (IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE) <> 0 then
  1590.         begin
  1591.           OleCheck(TypeInfo.GetRefTypeOfImplType(I, RefType));
  1592.           OleCheck(TypeInfo.GetRefTypeInfo(RefType, Temp));
  1593.           try
  1594.             Code := Temp.GetIDsOfNames(@Name, 1, @MemberID);
  1595.             if Code <> DISP_E_UNKNOWNNAME then
  1596.             begin
  1597.               OleCheck(Code);
  1598.               Exchange(TypeInfo, Temp);
  1599.               Result := True;
  1600.               Break;
  1601.             end;
  1602.           finally
  1603.             Temp.Release;
  1604.           end;
  1605.         end;
  1606.         Inc(I);
  1607.       end;
  1608.     finally
  1609.       SysFreeString(Name);
  1610.     end;
  1611.   end;
  1612.  
  1613. begin
  1614.   Result := False;
  1615.   HelpCtx := 0;
  1616.   HelpFile := '';
  1617.   CreateControl;
  1618.   OleCheck(FOleObject.QueryInterface(IID_IProvideClassInfo, ProvideClassInfo));
  1619.   try
  1620.     OleCheck(ProvideClassInfo.GetClassInfo(TypeInfo));
  1621.     try
  1622.       MemberID := MEMBERID_NIL;
  1623.       if Length(Member) > 0 then
  1624.       begin
  1625.         OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  1626.         ImplTypes := TypeAttr.cImplTypes;
  1627.         TypeInfo.ReleaseTypeAttr(TypeAttr);
  1628.         Result := Find(Member, TypeInfo);
  1629.         if (not Result) and (Member[Length(Member)] = '_') then
  1630.         begin
  1631.           Delete(Member, Length(Member)-1, 1);
  1632.           Result := Find(Member, TypeInfo);
  1633.         end;
  1634.         if (not Result) and (Pos('On', Member) = 1) then
  1635.         begin
  1636.           Delete(Member, 1, 2);
  1637.           Result := Find(Member, TypeInfo);
  1638.         end;
  1639.         if not Result then Exit;
  1640.       end;
  1641.       OleCheck(TypeInfo.GetDocumentation(MemberID, nil, nil, @HelpCtx, @HlpFile));
  1642.       HelpFile := OleStrToString(HlpFile);
  1643.       SysFreeString(HlpFile);
  1644.     finally
  1645.       TypeInfo.Release;
  1646.     end;
  1647.   finally
  1648.     ProvideClassInfo.Release;
  1649.   end;
  1650.   Result := True;
  1651. end;
  1652.  
  1653. function TOleControl.GetIntegerProp(Index: Integer): Integer;
  1654. var
  1655.   Temp: TVarData;
  1656. begin
  1657.   GetProperty(Index, Temp);
  1658.   Result := Temp.VInteger;
  1659. end;
  1660.  
  1661. function TOleControl.GetMainMenu: TMainMenu;
  1662. var
  1663.   Form: TForm;
  1664. begin
  1665.   Result := nil;
  1666.   Form := GetParentForm(Self);
  1667.   if Form <> nil then
  1668.     if Form.FormStyle <> fsMDIChild then
  1669.       Result := Form.Menu
  1670.     else
  1671.       if Application.MainForm <> nil then
  1672.         Result := Application.MainForm.Menu;
  1673. end;
  1674.  
  1675. procedure TOleControl.GetObjectVerbs(List: TStrings);
  1676. var
  1677.   I: Integer;
  1678.   S: string;
  1679.   EnumOleVerb: IEnumOleVerb;
  1680.   OleVerb: TOleVerb;
  1681. begin
  1682.   CreateControl;
  1683.   List.Clear;
  1684.   if FOleObject.EnumVerbs(EnumOleVerb) = 0 then
  1685.     try
  1686.       while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and
  1687.         (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do
  1688.       begin
  1689.         S := WideCharToString(OleVerb.lpszVerbName);
  1690.         for I := Length(S) downto 1 do if S[I] = '&' then Delete(S, I, 1);
  1691.         List.AddObject(S, TObject(OleVerb.lVerb));
  1692.       end;
  1693.     finally
  1694.       EnumOleVerb.Release;
  1695.     end;
  1696. end;
  1697.  
  1698. function TOleControl.GetOleBoolProp(Index: Integer): TOleBool;
  1699. var
  1700.   Temp: TVarData;
  1701. begin
  1702.   GetProperty(Index, Temp);
  1703.   Result := Temp.VBoolean;
  1704. end;
  1705.  
  1706. function TOleControl.GetOleDateProp(Index: Integer): TOleDate;
  1707. var
  1708.   Temp: TVarData;
  1709. begin
  1710.   GetProperty(Index, Temp);
  1711.   Result := Temp.VDate;
  1712. end;
  1713.  
  1714. function TOleControl.GetOleEnumProp(Index: Integer): TOleEnum;
  1715. begin
  1716.   Result := GetSmallintProp(Index);
  1717. end;
  1718.  
  1719. function TOleControl.GetOleObject: Variant;
  1720. begin
  1721.   CreateControl;
  1722.   Result := VarFromInterface(FOleObject);
  1723. end;
  1724.  
  1725. function TOleControl.GetPropDisplayString(DispID: Integer): string;
  1726. var
  1727.   BStr: TBStr;
  1728. begin
  1729.   CreateControl;
  1730.   if (FPropBrowsing <> nil) and
  1731.     (FPropBrowsing.GetDisplayString(DispID, BStr) = 0) then
  1732.   begin
  1733.     Result := OleStrToString(BStr);
  1734.     SysFreeString(BStr);
  1735.   end else
  1736.     Result := GetStringProp(DispID);
  1737. end;
  1738.  
  1739. procedure TOleControl.GetPropDisplayStrings(DispID: Integer; List: TStrings);
  1740. var
  1741.   Strings: TCAPOleStr;
  1742.   Cookies: TCALongint;
  1743.   I: Integer;
  1744. begin
  1745.   CreateControl;
  1746.   List.Clear;
  1747.   if (FPropBrowsing <> nil) and
  1748.     (FPropBrowsing.GetPredefinedStrings(DispID, Strings, Cookies) = 0) then
  1749.     try
  1750.       for I := 0 to Strings.cElems - 1 do
  1751.         List.AddObject(WideCharToString(Strings.pElems^[I]),
  1752.           TObject(Cookies.pElems^[I]));
  1753.     finally
  1754.       for I := 0 to Strings.cElems - 1 do
  1755.         CoTaskMemFree(Strings.pElems^[I]);
  1756.       CoTaskMemFree(Strings.pElems);
  1757.       CoTaskMemFree(Cookies.pElems);
  1758.     end;
  1759. end;
  1760.  
  1761. procedure TOleControl.GetProperty(Index: Integer; var Value: TVarData);
  1762. const
  1763.   DispParams: TDispParams = ();
  1764. var
  1765.   Status: HResult;
  1766.   ExcepInfo: TExcepInfo;
  1767. begin
  1768.   CreateControl;
  1769.   FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
  1770.   Value.VType := varEmpty;
  1771.   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
  1772.     DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil);
  1773.   if Status <> 0 then DispInvokeError(Status, ExcepInfo);
  1774. end;
  1775.  
  1776. function TOleControl.GetSingleProp(Index: Integer): Single;
  1777. var
  1778.   Temp: TVarData;
  1779. begin
  1780.   GetProperty(Index, Temp);
  1781.   Result := Temp.VSingle;
  1782. end;
  1783.  
  1784. function TOleControl.GetSmallintProp(Index: Integer): Smallint;
  1785. var
  1786.   Temp: TVarData;
  1787. begin
  1788.   GetProperty(Index, Temp);
  1789.   Result := Temp.VSmallint;
  1790. end;
  1791.  
  1792. function TOleControl.GetStringProp(Index: Integer): string;
  1793. var
  1794.   Temp: TVarData;
  1795. begin
  1796.   GetProperty(Index, Temp);
  1797.   try
  1798.     OleStrToStrVar(Temp.VOleStr, Result);
  1799.   finally
  1800.     SysFreeString(Temp.VOleStr);
  1801.   end;
  1802. end;
  1803.  
  1804. function TOleControl.GetVariantProp(Index: Integer): Variant;
  1805. begin
  1806.   VarClear(Result);
  1807.   GetProperty(Index, TVarData(Result));
  1808. end;
  1809.  
  1810. procedure TOleControl.HookControlWndProc;
  1811. var
  1812.   WndHandle: HWnd;
  1813. begin
  1814.   if (FOleInPlaceObject <> nil) and (WindowHandle = 0) then
  1815.   begin
  1816.     WndHandle := 0;
  1817.     FOleInPlaceObject.GetWindow(WndHandle);
  1818.     if WndHandle = 0 then raise EOleError.CreateRes(SNoWindowHandle);
  1819.     WindowHandle := WndHandle;
  1820.     DefWndProc := Pointer(GetWindowLong(WindowHandle, GWL_WNDPROC));
  1821.     CreationControl := Self;
  1822.     SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(@InitWndProc));
  1823.     SendMessage(WindowHandle, WM_NULL, 0, 0);
  1824.   end;
  1825. end;
  1826.  
  1827. procedure CallEventMethod(const EventInfo: TEventInfo);
  1828. asm
  1829.         PUSH    EBX
  1830.         PUSH    ESI
  1831.         PUSH    EBP
  1832.         MOV     EBP,ESP
  1833.         MOV     EBX,EAX
  1834.         MOV     EDX,[EBX].TEventInfo.ArgCount
  1835.         TEST    EDX,EDX
  1836.         JE      @@5
  1837.         XOR     EAX,EAX
  1838.         LEA     ESI,[EBX].TEventInfo.Args
  1839. @@1:    MOV     AL,[ESI].TEventArg.Kind
  1840.         CMP     AL,1
  1841.         JA      @@2
  1842.         JE      @@3
  1843.         TEST    AH,AH
  1844.         JNE     @@3
  1845.         MOV     ECX,[ESI].Integer[4]
  1846.         MOV     AH,1
  1847.         JMP     @@4
  1848. @@2:    PUSH    [ESI].Integer[8]
  1849. @@3:    PUSH    [ESI].Integer[4]
  1850. @@4:    ADD     ESI,12
  1851.         DEC     EDX
  1852.         JNE     @@1
  1853. @@5:    MOV     EDX,[EBX].TEventInfo.Sender
  1854.         MOV     EAX,[EBX].TEventInfo.Method.Data
  1855.         CALL    [EBX].TEventInfo.Method.Code
  1856.         MOV     ESP,EBP
  1857.         POP     EBP
  1858.         POP     ESI
  1859.         POP     EBX
  1860. end;
  1861.  
  1862. procedure TOleControl.InvokeEvent(DispID: TDispID; var Params: TDispParams);
  1863. type
  1864.   PVarArg = ^TVarArg;
  1865.   TVarArg = array[0..3] of Integer;
  1866.   TStringDesc = record
  1867.     PStr: Pointer;
  1868.     BStr: PBStr;
  1869.   end;
  1870. var
  1871.   I, J, K, ArgType, ArgCount, StrCount: Integer;
  1872.   ArgPtr: PEventArg;
  1873.   ParamPtr: PVarArg;
  1874.   Strings: array[0..MaxDispArgs - 1] of TStringDesc;
  1875.   EventInfo: TEventInfo;
  1876. begin
  1877.   GetEventMethod(DispID, EventInfo.Method);
  1878.   if Integer(EventInfo.Method.Code) >= $10000 then
  1879.   begin
  1880.     StrCount := 0;
  1881.     try
  1882.       ArgCount := Params.cArgs;
  1883.       EventInfo.Sender := Self;
  1884.       EventInfo.ArgCount := ArgCount;
  1885.       if ArgCount <> 0 then
  1886.       begin
  1887.         ParamPtr := @Params.rgvarg^[EventInfo.ArgCount];
  1888.         ArgPtr := @EventInfo.Args;
  1889.         I := 0;
  1890.         repeat
  1891.           Dec(Integer(ParamPtr), SizeOf(TVarArg));
  1892.           ArgType := ParamPtr^[0] and $0000FFFF;
  1893.           if ArgType and varTypeMask = varOleStr then
  1894.           begin
  1895.             ArgPtr^.Kind := akDWord;
  1896.             with Strings[StrCount] do
  1897.             begin
  1898.               PStr := nil;
  1899.               if ArgType and varByRef <> 0 then
  1900.               begin
  1901.                 OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr));
  1902.                 BStr := PBStr(ParamPtr^[2]);
  1903.                 ArgPtr^.Data[0] := Integer(@PStr);
  1904.               end else
  1905.               begin
  1906.                 OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr));
  1907.                 BStr := nil;
  1908.                 ArgPtr^.Data[0] := Integer(PStr);
  1909.               end;
  1910.             end;
  1911.             Inc(StrCount);
  1912.           end else
  1913.           begin
  1914.             case ArgType of
  1915.               varSingle:
  1916.                 begin
  1917.                   ArgPtr^.Kind := akSingle;
  1918.                   ArgPtr^.Data[0] := ParamPtr^[2];
  1919.                 end;
  1920.               varDouble..varDate:
  1921.                 begin
  1922.                   ArgPtr^.Kind := akDouble;
  1923.                   ArgPtr^.Data[0] := ParamPtr^[2];
  1924.                   ArgPtr^.Data[1] := ParamPtr^[3];
  1925.                 end;
  1926.               varDispatch:
  1927.                 begin
  1928.                   ArgPtr^.Kind := akDWord;
  1929.                   ArgPtr^.Data[0] := Integer(ParamPtr)
  1930.                 end;
  1931.             else
  1932.               ArgPtr^.Kind := akDWord;
  1933.               if (ArgType and varArray) <> 0 then
  1934.                 ArgPtr^.Data[0] := Integer(ParamPtr)
  1935.               else
  1936.                 ArgPtr^.Data[0] := ParamPtr^[2];
  1937.             end;
  1938.           end;
  1939.           Inc(Integer(ArgPtr), SizeOf(TEventArg));
  1940.           Inc(I);
  1941.         until I = EventInfo.ArgCount;
  1942.       end;
  1943.       CallEventMethod(EventInfo);
  1944.       J := StrCount;
  1945.       while J <> 0 do
  1946.       begin
  1947.         Dec(J);
  1948.         with Strings[J] do
  1949.           if BStr <> nil then BStr^ := StringToOleStr(string(PStr));
  1950.       end;
  1951.     except
  1952.       Application.HandleException(Self);
  1953.     end;
  1954.     K := StrCount;
  1955.     while K <> 0 do
  1956.     begin
  1957.       Dec(K);
  1958.       string(Strings[K].PStr) := '';
  1959.     end;
  1960.   end;
  1961. end;
  1962.  
  1963. procedure GetStringResult(BStr: TBStr; var Result: string);
  1964. begin
  1965.   try
  1966.     OleStrToStrVar(BStr, Result);
  1967.   finally
  1968.     SysFreeString(BStr);
  1969.   end;
  1970. end;
  1971.  
  1972. procedure TOleControl.InvokeMethod(var DispInfo; Result: Pointer); assembler;
  1973. asm
  1974.         PUSH    EBX
  1975.         PUSH    ESI
  1976.         PUSH    EDI
  1977.         MOV     EBX,EAX
  1978.         MOV     ESI,EDX
  1979.         MOV     EDI,ECX
  1980.         CALL    TOleControl.CreateControl
  1981.         PUSH    [ESI].TDispInfo.DispID
  1982.         MOV     ECX,ESP
  1983.         XOR     EAX,EAX
  1984.         PUSH    EAX
  1985.         PUSH    EAX
  1986.         PUSH    EAX
  1987.         PUSH    EAX
  1988.         MOV     EDX,ESP
  1989.         LEA     EAX,[EBP+16]
  1990.         CMP     [ESI].TDispInfo.ResType,varOleStr
  1991.         JE      @@1
  1992.         CMP     [ESI].TDispInfo.ResType,varVariant
  1993.         JE      @@1
  1994.         LEA     EAX,[EBP+12]
  1995. @@1:    PUSH    EAX
  1996.         PUSH    EDX
  1997.         LEA     EDX,[ESI].TDispInfo.CallDesc
  1998.         MOV     EAX,[EBX].TOleControl.FControlDispatch
  1999.         CALL    DispInvoke
  2000.         XOR     EAX,EAX
  2001.         MOV     AL,[ESI].TDispInfo.ResType
  2002.         JMP     @ResultTable.Pointer[EAX*4]
  2003.  
  2004. @ResultTable:
  2005.         DD      @ResEmpty
  2006.         DD      @ResNull
  2007.         DD      @ResSmallint
  2008.         DD      @ResInteger
  2009.         DD      @ResSingle
  2010.         DD      @ResDouble
  2011.         DD      @ResCurrency
  2012.         DD      @ResDate
  2013.         DD      @ResString
  2014.         DD      @ResDispatch
  2015.         DD      @ResError
  2016.         DD      @ResBoolean
  2017.         DD      @ResVariant
  2018.  
  2019. @ResSmallint:
  2020. @ResBoolean:
  2021.         MOV     AX,[ESP+8]
  2022.         MOV     [EDI],AX
  2023.         JMP     @ResDone
  2024.  
  2025. @ResString:
  2026.         MOV     EAX,[ESP+8]
  2027.         MOV     EDX,EDI
  2028.         CALL    GetStringResult
  2029.         JMP     @ResDone
  2030.  
  2031. @ResVariant:
  2032.         MOV     EAX,EDI
  2033.         CALL    VarClear
  2034.         MOV     ESI,ESP
  2035.         MOV     ECX,4
  2036.         REP     MOVSD
  2037.         JMP     @ResDone
  2038.  
  2039. @ResDouble:
  2040. @ResCurrency:
  2041. @ResDate:
  2042.         MOV     EAX,[ESP+12]
  2043.         MOV     [EDI+4],EAX
  2044.  
  2045. @ResInteger:
  2046. @ResSingle:
  2047.         MOV     EAX,[ESP+8]
  2048.         MOV     [EDI],EAX
  2049.  
  2050. @ResEmpty:
  2051. @ResNull:
  2052. @ResDispatch:
  2053. @ResError:
  2054. @ResDone:
  2055.         ADD     ESP,20
  2056.         POP     EDI
  2057.         POP     ESI
  2058.         POP     EBX
  2059. end;
  2060.  
  2061. function TOleControl.IsCustomProperty(DispID: Integer): Boolean;
  2062. begin
  2063.   Result := (FPropBrowsing <> nil) and
  2064.     (FPropBrowsing.GetDisplayString(DispID, PBStr(nil)^) = 0);
  2065. end;
  2066.  
  2067. function TOleControl.PaletteChanged(Foreground: Boolean): Boolean;
  2068. begin
  2069.   Result := False;
  2070.   if HandleAllocated and Foreground then
  2071.     Result := CallWindowProc(DefWndProc, Handle, WM_QUERYNEWPALETTE, 0, 0) <> 0;
  2072.   if not Result then
  2073.     Result := inherited PaletteChanged(Foreground);
  2074. end;
  2075.  
  2076. function TOleControl.QueryInterface(const iid: TIID; var obj): HResult;
  2077. var
  2078.   P: IUnknown;
  2079. begin
  2080.   P := nil;
  2081.   if IsEqualIID(iid, IID_IUnknown) or
  2082.     IsEqualIID(iid, IID_IOleClientSite) then P := FOleClientSite else
  2083.   if IsEqualIID(iid, IID_IOleControlSite) then P := FOleControlSite else
  2084.   if IsEqualIID(iid, IID_IOleInPlaceSite) then P := FOleInPlaceSite else
  2085.   if IsEqualIID(iid, IID_IDispatch) then P := FAmbientDispatch else
  2086.   if IsEqualIID(iid, IID_IPropertyNotifySink) then P := FPropertyNotifySink else
  2087.   if IsEqualIID(iid, IID_ISimpleFrameSite) then P := FSimpleFrameSite else
  2088.   if IsEqualIID(iid, FControlData^.EventIID) then P := FEventDispatch;
  2089.   Pointer(obj) := P;
  2090.   if P = nil then Result := E_NOINTERFACE else
  2091.   begin
  2092.     P.AddRef;
  2093.     Result := S_OK;
  2094.   end;
  2095. end;
  2096.  
  2097. procedure TOleControl.ReadData(Stream: TStream);
  2098. var
  2099.   Buffer: Pointer;
  2100. begin
  2101.   DestroyStorage;
  2102.   try
  2103.     FObjectData := GlobalAlloc(GMEM_MOVEABLE, Stream.Size);
  2104.     if FObjectData = 0 then OutOfMemoryError;
  2105.     Buffer := GlobalLock(FObjectData);
  2106.     try
  2107.       Stream.Read(Buffer^, Stream.Size);
  2108.     finally
  2109.       GlobalUnlock(FObjectData);
  2110.     end;
  2111.   except
  2112.     DestroyStorage;
  2113.   end;
  2114. end;
  2115.  
  2116. function TOleControl.Release: Longint;
  2117. begin
  2118.   Dec(FRefCount);
  2119.   Result := FRefCount;
  2120. end;
  2121.  
  2122. procedure TOleControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
  2123. begin
  2124.   if (AWidth <> Width) or (AHeight <> Height) then
  2125.     if (FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) or
  2126.       (FOleControl <> nil) and
  2127.       (FOleObject.SetExtent(DVASPECT_CONTENT, Point(
  2128.       MulDiv(AWidth, 2540, PixPerInch.X),
  2129.       MulDiv(AHeight, 2540, PixPerInch.Y))) <> S_OK) then
  2130.     begin
  2131.       AWidth := Width;
  2132.       AHeight := Height;
  2133.     end;
  2134.   inherited SetBounds(ALeft, ATop, AWidth, AHeight);
  2135. end;
  2136.  
  2137. procedure TOleControl.SetColorProp(Index: Integer; Value: TColor);
  2138. begin
  2139.   SetIntegerProp(Index, Value);
  2140. end;
  2141.  
  2142. procedure TOleControl.SetCurrencyProp(Index: Integer; Value: TCurrency);
  2143. var
  2144.   Temp: TVarData;
  2145. begin
  2146.   Temp.VType := varCurrency;
  2147.   Temp.VCurrency := Value;
  2148.   SetProperty(Index, Temp);
  2149. end;
  2150.  
  2151. procedure TOleControl.SetDoubleProp(Index: Integer; Value: Double);
  2152. var
  2153.   Temp: TVarData;
  2154. begin
  2155.   Temp.VType := varDouble;
  2156.   Temp.VDouble := Value;
  2157.   SetProperty(Index, Temp);
  2158. end;
  2159.  
  2160. procedure TOleControl.SetIntegerProp(Index: Integer; Value: Integer);
  2161. var
  2162.   Temp: TVarData;
  2163. begin
  2164.   Temp.VType := varInteger;
  2165.   Temp.VInteger := Value;
  2166.   SetProperty(Index, Temp);
  2167. end;
  2168.  
  2169. procedure TOleControl.SetName(const Value: TComponentName);
  2170. var
  2171.   OldName: string;
  2172.   DispID: Integer;
  2173. begin
  2174.   OldName := Name;
  2175.   inherited SetName(Value);
  2176.   if FOleControl <> nil then
  2177.   begin
  2178.     FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME);
  2179.     if FControlData^.Flags and (cfCaption or cfText) <> 0 then
  2180.     begin
  2181.       if FControlData^.Flags and cfCaption <> 0 then
  2182.         DispID := DISPID_CAPTION else
  2183.         DispID := DISPID_TEXT;
  2184.       if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value);
  2185.     end;
  2186.   end;
  2187. end;
  2188.  
  2189. procedure TOleControl.SetOleBoolProp(Index: Integer; Value: TOleBool);
  2190. var
  2191.   Temp: TVarData;
  2192. begin
  2193.   Temp.VType := varBoolean;
  2194.   if Value then
  2195.     Temp.VBoolean := WordBool(-1) else
  2196.     Temp.VBoolean := WordBool(0);
  2197.   SetProperty(Index, Temp);
  2198. end;
  2199.  
  2200. procedure TOleControl.SetOleDateProp(Index: Integer; Value: TOleDate);
  2201. var
  2202.   Temp: TVarData;
  2203. begin
  2204.   Temp.VType := varDate;
  2205.   Temp.VDate := Value;
  2206.   SetProperty(Index, Temp);
  2207. end;
  2208.  
  2209. procedure TOleControl.SetOleEnumProp(Index: Integer; Value: TOleEnum);
  2210. begin
  2211.   SetSmallintProp(Index, Value);
  2212. end;
  2213.  
  2214. procedure TOleControl.SetPropDisplayString(DispID: Integer;
  2215.   const Value: string);
  2216. var
  2217.   I: Integer;
  2218.   Values: TStringList;
  2219.   V: Variant;
  2220. begin
  2221.   Values := TStringList.Create;
  2222.   try
  2223.     GetPropDisplayStrings(DispID, Values);
  2224.     for I := 0 to Values.Count - 1 do
  2225.       if AnsiCompareText(Value, Values[I]) = 0 then
  2226.       begin
  2227.         OleCheck(FPropBrowsing.GetPredefinedValue(DispID,
  2228.           Integer(Values.Objects[I]), V));
  2229.         SetProperty(DispID, TVarData(V));
  2230.         Exit;
  2231.       end;
  2232.   finally
  2233.     Values.Free;
  2234.   end;
  2235.   SetStringProp(DispID, Value);
  2236. end;
  2237.  
  2238. procedure TOleControl.SetProperty(Index: Integer; const Value: TVarData);
  2239. const
  2240.   DispIDArgs: Longint = DISPID_PROPERTYPUT;
  2241. var
  2242.   Status, InvKind: Integer;
  2243.   DispParams: TDispParams;
  2244.   ExcepInfo: TExcepInfo;
  2245. begin
  2246.   CreateControl;
  2247.   DispParams.rgvarg := @Value;
  2248.   DispParams.rgdispidNamedArgs := @DispIDArgs;
  2249.   DispParams.cArgs := 1;
  2250.   DispParams.cNamedArgs := 1;
  2251.   FillChar(ExcepInfo, SizeOf(ExcepInfo), 0);
  2252.   if Value.VType <> varDispatch then
  2253.     InvKind := DISPATCH_PROPERTYPUT else
  2254.     InvKind := DISPATCH_PROPERTYPUTREF;
  2255.   Status := FControlDispatch.Invoke(Index, GUID_NULL, 0,
  2256.     InvKind, DispParams, nil, @ExcepInfo, nil);
  2257.   if Status <> 0 then DispInvokeError(Status, ExcepInfo);
  2258. end;
  2259.  
  2260. procedure TOleControl.SetSingleProp(Index: Integer; Value: Single);
  2261. var
  2262.   Temp: TVarData;
  2263. begin
  2264.   Temp.VType := varSingle;
  2265.   Temp.VSingle := Value;
  2266.   SetProperty(Index, Temp);
  2267. end;
  2268.  
  2269. procedure TOleControl.SetSmallintProp(Index: Integer; Value: Smallint);
  2270. var
  2271.   Temp: TVarData;
  2272. begin
  2273.   Temp.VType := varSmallint;
  2274.   Temp.VSmallint := Value;
  2275.   SetProperty(Index, Temp);
  2276. end;
  2277.  
  2278. procedure TOleControl.SetStringProp(Index: Integer; const Value: string);
  2279. var
  2280.   Temp: TVarData;
  2281. begin
  2282.   Temp.VType := varOleStr;
  2283.   Temp.VOleStr := StringToOleStr(Value);
  2284.   try
  2285.     SetProperty(Index, Temp);
  2286.   finally
  2287.     SysFreeString(Temp.VOleStr);
  2288.   end;
  2289. end;
  2290.  
  2291. procedure TOleControl.SetUIActive(Active: Boolean);
  2292. var
  2293.   Form: TForm;
  2294. begin
  2295.   Form := GetParentForm(Self);
  2296.   if Form <> nil then
  2297.     if Active then
  2298.     begin
  2299.       if (Form.ActiveOleControl <> nil) and
  2300.         (Form.ActiveOleControl <> Self) then
  2301.         Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  2302.       Form.ActiveOleControl := Self;
  2303.     end else
  2304.       if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil;
  2305. end;
  2306.  
  2307. procedure TOleControl.SetVariantProp(Index: Integer; const Value: Variant);
  2308. begin
  2309.   if TVarData(Value).VType = varString then
  2310.     SetStringProp(Index, string(TVarData(Value).VString))
  2311.   else
  2312.     SetProperty(Index, TVarData(Value));
  2313. end;
  2314.  
  2315. procedure TOleControl.ShowAboutBox;
  2316. const
  2317.   DispInfo: array[0..7] of Byte = ($D8,$FD,$FF,$FF,$00,$01,$00,$00);
  2318. begin
  2319.   InvokeMethod(DispInfo, nil);
  2320. end;
  2321.  
  2322. procedure TOleControl.StandardEvent(DispID: TDispID; var Params: TDispParams);
  2323. type
  2324.   PVarDataList = ^TVarDataList;
  2325.   TVarDataList = array[0..3] of TVarData;
  2326. const
  2327.   ShiftMap: array[0..7] of TShiftState = (
  2328.     [],
  2329.     [ssShift],
  2330.     [ssCtrl],
  2331.     [ssShift, ssCtrl],
  2332.     [ssAlt],
  2333.     [ssShift, ssAlt],
  2334.     [ssCtrl, ssAlt],
  2335.     [ssShift, ssCtrl, ssAlt]);
  2336.   MouseMap: array[0..7] of TShiftState = (
  2337.     [],
  2338.     [ssLeft],
  2339.     [ssRight],
  2340.     [ssLeft, ssRight],
  2341.     [ssMiddle],
  2342.     [ssLeft, ssMiddle],
  2343.     [ssRight, ssMiddle],
  2344.     [ssLeft, ssRight, ssMiddle]);
  2345.   ButtonMap: array[0..7] of TMouseButton = (
  2346.     mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft);
  2347. var
  2348.   Args: PVarDataList;
  2349.   Shift: TShiftState;
  2350.   Button: TMouseButton;
  2351.   X, Y: Integer;
  2352. begin
  2353.   Args := PVarDataList(Params.rgvarg);
  2354.   try
  2355.     case DispID of
  2356.       DISPID_CLICK:
  2357.         Click;
  2358.       DISPID_DBLCLICK:
  2359.         DblClick;
  2360.       DISPID_KEYDOWN:
  2361.         KeyDown(Word(Args^[1].VPointer^), ShiftMap[Args^[0].VInteger and 7]);
  2362.       DISPID_KEYPRESS:
  2363.         KeyPress(Char(Args^[0].VPointer^));
  2364.       DISPID_KEYUP:
  2365.         KeyUp(Word(Args^[1].VPointer^), ShiftMap[Args^[0].VInteger and 7]);
  2366.       DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP:
  2367.         begin
  2368.           Button := ButtonMap[Args^[3].VInteger and 7];
  2369.           Shift := ShiftMap[Args^[2].VInteger and 7] +
  2370.             MouseMap[Args^[3].VInteger and 7];
  2371.           X := Args^[1].VInteger;
  2372.           Y := Args^[0].VInteger;
  2373.           case DispID of
  2374.             DISPID_MOUSEDOWN:
  2375.               MouseDown(Button, Shift, X, Y);
  2376.             DISPID_MOUSEMOVE:
  2377.               MouseMove(Shift, X, Y);
  2378.             DISPID_MOUSEUP:
  2379.               MouseUp(Button, Shift, X, Y);
  2380.           end;
  2381.         end;
  2382.     end;
  2383.   except
  2384.     Application.HandleException(Self);
  2385.   end;
  2386. end;
  2387.  
  2388. procedure TOleControl.WndProc(var Message: TMessage);
  2389. var
  2390.   WinMsg: TMsg;
  2391. begin
  2392.   if (Message.Msg >= CN_BASE + WM_KEYFIRST) and
  2393.     (Message.Msg <= CN_BASE + WM_KEYLAST) and
  2394.     (FOleInPlaceActiveObject <> nil) then
  2395.   begin
  2396.     WinMsg.HWnd := Handle;
  2397.     WinMsg.Message := Message.Msg - CN_BASE;
  2398.     WinMsg.WParam := Message.WParam;
  2399.     WinMsg.LParam := Message.LParam;
  2400.     WinMsg.Time := GetMessageTime;
  2401.     WinMsg.Pt.X := 0;
  2402.     WinMsg.Pt.Y := 0;
  2403.     if FOleInPlaceActiveObject.TranslateAccelerator(WinMsg) = S_OK then
  2404.     begin
  2405.       Message.Result := 1;
  2406.       Exit;
  2407.     end;
  2408.   end;
  2409.   inherited WndProc(Message);
  2410. end;
  2411.  
  2412. procedure TOleControl.WriteData(Stream: TStream);
  2413. var
  2414.   StorageExists: Boolean;
  2415.   Buffer: Pointer;
  2416. begin
  2417.   StorageExists := FObjectData <> 0;
  2418.   if not StorageExists then CreateStorage;
  2419.   try
  2420.     Buffer := GlobalLock(FObjectData);
  2421.     try
  2422.       Stream.Write(Buffer^, GlobalSize(FObjectData));
  2423.     finally
  2424.       GlobalUnlock(FObjectData);
  2425.     end;
  2426.   finally
  2427.     if not StorageExists then DestroyStorage;
  2428.   end;
  2429. end;
  2430.  
  2431. procedure TOleControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
  2432. begin
  2433.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  2434.     DefaultHandler(Message) else
  2435.     inherited;
  2436. end;
  2437.  
  2438. procedure TOleControl.WMPaint(var Message: TWMPaint);
  2439. var
  2440.   DC: HDC;
  2441.   PS: TPaintStruct;
  2442. begin
  2443.   if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then
  2444.   begin
  2445.     DC := Message.DC;
  2446.     if DC = 0 then DC := BeginPaint(Handle, PS);
  2447.     OleDraw(FOleObject, DVASPECT_CONTENT, DC, ClientRect);
  2448.     if Message.DC = 0 then EndPaint(Handle, PS);
  2449.   end else
  2450.     inherited;
  2451. end;
  2452.  
  2453. procedure TOleControl.CMDocWindowActivate(var Message: TMessage);
  2454. begin
  2455.   if GetParentForm(Self).FormStyle = fsMDIChild then
  2456.   begin
  2457.     FOleInPlaceActiveObject.OnDocWindowActivate(LongBool(Message.WParam));
  2458.     if Message.WParam = 0 then FOleInPlaceFrame.SetMenu(0, 0, 0);
  2459.   end;
  2460. end;
  2461.  
  2462. procedure TOleControl.CMColorChanged(var Message: TMessage);
  2463. begin
  2464.   inherited;
  2465.   if (FControlData^.Flags and cfBackColor <> 0) and not FUpdatingColor and
  2466.     HandleAllocated then
  2467.   begin
  2468.     FUpdatingColor := True;
  2469.     try
  2470.       SetColorProp(DISPID_BACKCOLOR, Color);
  2471.     finally
  2472.       FUpdatingColor := False;
  2473.     end;
  2474.   end;
  2475. end;
  2476.  
  2477. procedure TOleControl.CMEnabledChanged(var Message: TMessage);
  2478. begin
  2479.   inherited;
  2480.   if (FControlData^.Flags and cfEnabled <> 0) and not FUpdatingEnabled and
  2481.     HandleAllocated then
  2482.   begin
  2483.     FUpdatingEnabled := True;
  2484.     try
  2485.       SetOleBoolProp(DISPID_ENABLED, Enabled);
  2486.     finally
  2487.       FUpdatingEnabled := False;
  2488.     end;
  2489.   end;
  2490. end;
  2491.  
  2492. procedure TOleControl.CMFontChanged(var Message: TMessage);
  2493. begin
  2494.   inherited;
  2495.   if (FControlData^.Flags and (cfForeColor or cfFont) <> 0) and
  2496.     not FUpdatingFont and HandleAllocated then
  2497.   begin
  2498.     FUpdatingFont := True;
  2499.     try
  2500.       if FControlData^.Flags and cfForeColor <> 0 then
  2501.         SetIntegerProp(DISPID_FORECOLOR, Font.Color);
  2502.       if FControlData^.Flags and cfFont <> 0 then
  2503.         SetVariantProp(DISPID_FONT, FontToOleFont(Font));
  2504.     finally
  2505.       FUpdatingFont := False;
  2506.     end;
  2507.   end;
  2508. end;
  2509.  
  2510. procedure TOleControl.CMDialogKey(var Message: TMessage);
  2511. var
  2512.   Info: TControlInfo;
  2513.   Msg: TMsg;
  2514.   Cmd: Word;
  2515. begin
  2516.   if CanFocus then
  2517.   begin
  2518.     Info.cb := SizeOf(Info);
  2519.     if (FOleControl.GetControlInfo(Info) = S_OK) and (Info.cAccel <> 0) then
  2520.     begin
  2521.       FillChar(Msg, SizeOf(Msg), 0);
  2522.       Msg.hwnd := Handle;
  2523.       Msg.message := WM_KEYDOWN;
  2524.       Msg.wParam := Message.WParam;
  2525.       Msg.lParam := Message.LParam;
  2526.       if IsAccelerator(Info.hAccel, Info.cAccel, @Msg, Cmd) then
  2527.       begin
  2528.         FOleControl.OnMnemonic(@Msg);
  2529.         Message.Result := 1;
  2530.         Exit;
  2531.       end;
  2532.     end;
  2533.   end;
  2534.   inherited;
  2535. end;
  2536.  
  2537. procedure TOleControl.CMUIActivate(var Message: TMessage);
  2538. begin
  2539.   if GetParentForm(Self).ActiveOleControl <> Self then
  2540.     FOleObject.DoVerb(OLEIVERB_UIACTIVATE, nil, FOleClientSite, 0,
  2541.       Parent.Handle, BoundsRect);
  2542. end;
  2543.  
  2544. procedure TOleControl.CMUIDeactivate(var Message: TMessage);
  2545. begin
  2546.   if GetParentForm(Self).ActiveOleControl = Self then
  2547.     FOleInPlaceObject.UIDeactivate;
  2548. end;
  2549.  
  2550. procedure Initialize;
  2551. var
  2552.   DC: HDC;
  2553. begin
  2554.   DC := GetDC(0);
  2555.   PixPerInch.X := GetDeviceCaps(DC, LOGPIXELSX);
  2556.   PixPerInch.Y := GetDeviceCaps(DC, LOGPIXELSY);
  2557.   ReleaseDC(0, DC);
  2558. end;
  2559.  
  2560. initialization
  2561. begin
  2562.   Initialize;
  2563. end;
  2564.  
  2565. end.
  2566.