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