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