home *** CD-ROM | disk | FTP | other *** search
/ QBasic & Borland Pascal & C / Delphi5.iso / Runimage / Delphi50 / Source / Vcl / OLECTNRS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-11  |  75.0 KB  |  2,676 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Borland Delphi Visual Component Library         }
  5. {                                                       }
  6. {       Copyright (c) 1995,99 Inprise Corporation       }
  7. {                                                       }
  8. {*******************************************************}
  9.  
  10. (*$HPPEMIT '#include <DocObj.h>'*)
  11.  
  12. unit OleCtnrs;
  13.  
  14. {$T-,H+,X+}
  15.  
  16. interface
  17.  
  18. uses Windows, Messages, CommCtrl, ActiveX, OleDlg, SysUtils, Classes,
  19.   Controls, Forms, Menus, Graphics, ComObj;
  20.  
  21. const
  22.   ovShow = -1;
  23.   ovOpen = -2;
  24.   ovHide = -3;
  25.   ovUIActivate = -4;
  26.   ovInPlaceActivate = -5;
  27.   ovDiscardUndoState = -6;
  28.   ovPrimary = -65536;
  29.  
  30. type
  31.   TOleContainer = class;
  32.   TOleForm = class;
  33.  
  34.   IVCLFrameForm = interface(IOleInPlaceFrame)
  35.     ['{CD02E1C0-52DA-11D0-9EA6-0020AF3D82DA}']
  36.     procedure AddContainer(Instance: TOleContainer);
  37.     procedure RemoveContainer(Instance: TOleContainer);
  38.     procedure ClearBorderSpace;
  39.     function Form: TCustomForm;
  40.   end;
  41.  
  42.   TAutoActivate = (aaManual, aaGetFocus, aaDoubleClick);
  43.  
  44.   TSizeMode = (smClip, smCenter, smScale, smStretch, smAutoSize);
  45.  
  46.   TObjectState = (osEmpty, osLoaded, osRunning, osOpen, osInPlaceActive,
  47.     osUIActive);
  48.  
  49.   TCreateType = (ctNewObject, ctFromFile, ctLinkToFile, ctFromData,
  50.     ctLinkFromData);
  51.  
  52.   TCreateInfo = record
  53.     CreateType: TCreateType;
  54.     ShowAsIcon: Boolean;
  55.     IconMetaPict: HGlobal;
  56.     ClassID: TCLSID;
  57.     FileName: WideString;
  58.     DataObject: IDataObject;
  59.   end;
  60.  
  61.   TVerbInfo = packed record
  62.     Verb: Smallint;
  63.     Flags: Word;
  64.   end;
  65.  
  66.   TObjectMoveEvent = procedure(OleContainer: TOleContainer;
  67.     const Bounds: TRect) of object;
  68.  
  69.   TOleContainer = class(TCustomControl, IUnknown, IOleClientSite,
  70.     IOleInPlaceSite, IAdviseSink, IOleDocumentSite, IOleUIObjInfo)
  71.   private
  72.     FRefCount: Longint;
  73.     FLockBytes: ILockBytes;
  74.     FStorage: IStorage;
  75.     FOleObject: IOleObject;
  76.     FDrawAspect: Longint;
  77.     FViewSize: TPoint;
  78.     FObjectVerbs: TStringList;
  79.     FDataConnection: Longint;
  80.     FDocForm: IVCLFrameForm;
  81.     FFrameForm: IVCLFrameForm;
  82.     FOleInPlaceObject: IOleInPlaceObject;
  83.     FOleInPlaceActiveObject: IOleInPlaceActiveObject;
  84.     FAccelTable: HAccel;
  85.     FAccelCount: Integer;
  86.     FPopupVerbMenu: TPopupMenu;
  87.     FAllowInPlace: Boolean;
  88.     FAllowActiveDoc: Boolean;
  89.     FAutoActivate: TAutoActivate;
  90.     FAutoVerbMenu: Boolean;
  91.     FBorderStyle: TBorderStyle;
  92.     FCopyOnSave: Boolean;
  93.     FOldStreamFormat: Boolean;
  94.     FSizeMode: TSizeMode;
  95.     FObjectOpen: Boolean;
  96.     FUIActive: Boolean;
  97.     FModified: Boolean;
  98.     FModSinceSave: Boolean;
  99.     FFocused: Boolean;
  100.     FNewInserted: Boolean;
  101.     FOnActivate: TNotifyEvent;
  102.     FOnDeactivate: TNotifyEvent;
  103.     FOnObjectMove: TObjectMoveEvent;
  104.     FOnResize: TNotifyEvent;
  105.     FDocView: IOleDocumentView;
  106.     FDocObj: Boolean;
  107.     { IOleClientSite }
  108.     function SaveObject: HResult; stdcall;
  109.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  110.       out mk: IMoniker): HResult; stdcall;
  111.     function GetContainer(out container: IOleContainer): HResult; stdcall;
  112.     function ShowObject: HResult; stdcall;
  113.     function OnShowWindow(fShow: BOOL): HResult; stdcall;
  114.     function RequestNewObjectLayout: HResult; stdcall;
  115.     { IOleInPlaceSite }
  116.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  117.     function GetWindow(out wnd: HWnd): HResult; stdcall;
  118.     function CanInPlaceActivate: HResult; stdcall;
  119.     function OnInPlaceActivate: HResult; stdcall;
  120.     function OnUIActivate: HResult; stdcall;
  121.     function GetWindowContext(out frame: IOleInPlaceFrame;
  122.       out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
  123.       out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
  124.       stdcall;
  125.     function Scroll(scrollExtent: TPoint): HResult; stdcall;
  126.     function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
  127.     function OnInPlaceDeactivate: HResult; stdcall;
  128.     function DiscardUndoState: HResult; stdcall;
  129.     function DeactivateAndUndo: HResult; stdcall;
  130.     function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
  131.     { IAdviseSink }
  132.     procedure OnDataChange(const formatetc: TFormatEtc;
  133.       const stgmed: TStgMedium); stdcall;
  134.     procedure OnViewChange(dwAspect: Longint; lindex: Longint); stdcall;
  135.     procedure OnRename(const mk: IMoniker); stdcall;
  136.     procedure OnSave; stdcall;
  137.     procedure OnClose; stdcall;
  138.     { IOleDocumentSite }
  139.     function ActivateMe(View: IOleDocumentView): HRESULT; stdcall;
  140.     { IOleUIObjInfo }
  141.     function GetObjectInfo(dwObject: Longint;
  142.       var dwObjSize: Longint; var lpszLabel: PChar;
  143.       var lpszType: PChar; var lpszShortType: PChar;
  144.       var lpszLocation: PChar): HResult; stdcall;
  145.     function GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;
  146.       var wFormat: Word; var ConvertDefaultClassID: TCLSID;
  147.       var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult; stdcall;
  148.     function ConvertObject(dwObject: Longint;
  149.       const clsidNew: TCLSID): HResult; stdcall;
  150.     function GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal;
  151.       var dvAspect: Longint; var nCurrentScale: Integer): HResult; stdcall;
  152.     function SetViewInfo(dwObject: Longint; hMetaPict: HGlobal;
  153.       dvAspect: Longint; nCurrentScale: Integer;
  154.       bRelativeToOrig: BOOL): HResult; stdcall;
  155.     { TOleContainer }
  156.     procedure AdjustBounds;
  157.     procedure CheckObject;
  158.     procedure CreateAccelTable;
  159.     procedure CreateStorage;
  160.     procedure DesignModified;
  161.     procedure DestroyAccelTable;
  162.     procedure DestroyVerbs;
  163.     function GetBorderWidth: Integer;
  164.     function GetCanPaste: Boolean;
  165.     function GetIconic: Boolean;
  166.     function GetLinked: Boolean;
  167.     function GetObjectDataSize: Integer;
  168.     function GetObjectVerbs: TStrings;
  169.     function GetOleClassName: string;
  170.     function GetOleObject: Variant;
  171.     function GetPrimaryVerb: Integer;
  172.     function GetSourceDoc: string;
  173.     function GetState: TObjectState;
  174.     procedure InitObject;
  175.     procedure ObjectMoved(const ObjectRect: TRect);
  176.     procedure PopupVerbMenuClick(Sender: TObject);
  177.     procedure SetBorderStyle(Value: TBorderStyle);
  178.     procedure SetDrawAspect(Iconic: Boolean; IconMetaPict: HGlobal);
  179.     procedure SetFocused(Value: Boolean);
  180.     procedure SetIconic(Value: Boolean);
  181.     procedure SetSizeMode(Value: TSizeMode);
  182.     procedure SetUIActive(Active: Boolean);
  183.     procedure SetViewAdviseSink(Enable: Boolean);
  184.     procedure UpdateObjectRect;
  185.     procedure UpdateView;
  186.     procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
  187.     procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
  188.     procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
  189.     procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
  190.     procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
  191.     procedure WMSize(var Message: TWMSize); message WM_SIZE;
  192.     procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  193.   protected
  194.     { IUnknown }
  195.     function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
  196.     function _AddRef: Integer; stdcall;
  197.     function _Release: Integer; stdcall;
  198.     procedure Changed; dynamic;
  199.     procedure CreateParams(var Params: TCreateParams); override;
  200.     procedure DblClick; override;
  201.     procedure DefineProperties(Filer: TFiler); override;
  202.     procedure DoEnter; override;
  203.     function GetPopupMenu: TPopupMenu; override;
  204.     procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  205.     procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
  206.       X, Y: Integer); override;
  207.     procedure Paint; override;
  208.   public
  209.     constructor Create(AOwner: TComponent); override;
  210.     destructor Destroy; override;
  211.     function ChangeIconDialog: Boolean;
  212.     procedure Close;
  213.     procedure Copy;
  214.     procedure CreateLinkToFile(const FileName: string; Iconic: Boolean);
  215.     procedure CreateObject(const OleClassName: string; Iconic: Boolean);
  216.     procedure CreateObjectFromFile(const FileName: string; Iconic: Boolean);
  217.     procedure CreateObjectFromInfo(const CreateInfo: TCreateInfo);
  218.     procedure DestroyObject;
  219.     procedure DoVerb(Verb: Integer);
  220.     function GetIconMetaPict: HGlobal;
  221.     function InsertObjectDialog: Boolean;
  222.     procedure LoadFromFile(const FileName: string);
  223.     procedure LoadFromStream(Stream: TStream);
  224.     function ObjectPropertiesDialog: Boolean;
  225.     procedure Paste;
  226.     function PasteSpecialDialog: Boolean;
  227.     procedure Run;
  228.     procedure SaveAsDocument(const FileName: string);
  229.     procedure SaveToFile(const FileName: string);
  230.     procedure SaveToStream(Stream: TStream);
  231.     procedure UpdateObject;
  232.     procedure UpdateVerbs;
  233.     property CanPaste: Boolean read GetCanPaste;
  234.     property Linked: Boolean read GetLinked;
  235.     property Modified: Boolean read FModified write FModified;
  236.     property NewInserted: Boolean read FNewInserted;
  237.     property ObjectVerbs: TStrings read GetObjectVerbs;
  238.     property OleClassName: string read GetOleClassName;
  239.     property OleObject: Variant read GetOleObject;
  240.     property OleObjectInterface: IOleObject read FOleObject;
  241.     property PrimaryVerb: Integer read GetPrimaryVerb;
  242.     property SourceDoc: string read GetSourceDoc;
  243.     property State: TObjectState read GetState;
  244.     property StorageInterface: IStorage read FStorage;
  245.   published
  246.     property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;
  247.     property AllowActiveDoc: Boolean read FAllowActiveDoc write FAllowActiveDoc default True;
  248.     property AutoActivate: TAutoActivate read FAutoActivate write FAutoActivate default aaDoubleClick;
  249.     property AutoVerbMenu: Boolean read FAutoVerbMenu write FAutoVerbMenu default True;
  250.     property Align;
  251.     property Anchors;
  252.     property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
  253.     property Caption;
  254.     property Color;
  255.     property Constraints;
  256.     property CopyOnSave: Boolean read FCopyOnSave write FCopyOnSave default True;
  257.     property Ctl3D;
  258.     property DragCursor;
  259.     property DragMode;
  260.     property Enabled;
  261.     property Iconic: Boolean read GetIconic write SetIconic stored False;
  262.     property OldStreamFormat: Boolean read FOldStreamFormat write FOldStreamFormat default False;
  263.     property ParentColor default False;
  264.     property ParentCtl3D;
  265.     property ParentShowHint;
  266.     property PopupMenu;
  267.     property ShowHint;
  268.     property SizeMode: TSizeMode read FSizeMode write SetSizeMode default smClip;
  269.     property TabOrder;
  270.     property TabStop default True;
  271.     property Visible;
  272.     property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
  273.     property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
  274.     property OnDragDrop;
  275.     property OnDragOver;
  276.     property OnEndDrag;
  277.     property OnEnter;
  278.     property OnExit;
  279.     property OnMouseDown;
  280.     property OnMouseMove;
  281.     property OnMouseUp;
  282.     property OnKeyDown;
  283.     property OnKeyPress;
  284.     property OnKeyUp;
  285.     property OnObjectMove: TObjectMoveEvent read FOnObjectMove write FOnObjectMove;
  286.     property OnResize: TNotifyEvent read FOnResize write FOnResize;
  287.     property OnStartDrag;
  288.   end;
  289.  
  290.   TOleForm = class(TInterfacedObject, IOleForm, IOleWindow, IOleInPlaceUIWindow,
  291.     IOleInPlaceFrame, IVCLFrameForm)
  292.   private
  293.     FForm: TCustomForm;
  294.     FContainers: TList;
  295.     FActiveObject: IOleInPlaceActiveObject;
  296.     FSaveWidth: Integer;
  297.     FSaveHeight: Integer;
  298.     FHiddenControls: TList;
  299.     FSpacers: array[0..3] of TControl;
  300.     { IOleForm }
  301.     procedure OnDestroy;
  302.     procedure OnResize;
  303.     { IOleWindow }
  304.     function GetWindow(out wnd: HWnd): HResult; stdcall;
  305.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  306.     { IOleInPlaceUIWindow }
  307.     function GetBorder(out BorderRect: TRect): HResult; stdcall;
  308.     function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
  309.     function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
  310.     function SetActiveObject(const ActiveObject: IOleInPlaceActiveObject;
  311.       pszObjName: POleStr): HResult; stdcall;
  312.     { IOleInPlaceFrame }
  313.     function InsertMenus(hmenuShared: HMenu;
  314.       var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
  315.     function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  316.       hwndActiveObject: HWnd): HResult; stdcall;
  317.     function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
  318.     function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
  319.     function EnableModeless(fEnable: BOOL): HResult; stdcall;
  320.     function TranslateAccelerator(var msg: TMsg; wID: Word): HResult; stdcall;
  321.     { IVCLFrameForm }
  322.     procedure AddContainer(Instance: TOleContainer);
  323.     procedure RemoveContainer(Instance: TOleContainer);
  324.     function Form: TCustomForm;
  325.     procedure ClearBorderSpace;
  326.     { TOleForm }
  327.     function IsSpacer(Control: TControl): Boolean;
  328.     function IsToolControl(Control: TControl): Boolean;
  329.   public
  330.     constructor Create(Form: TCustomForm);
  331.     destructor Destroy; override;
  332.   end;
  333.  
  334. procedure DestroyMetaPict(MetaPict: HGlobal);
  335.  
  336. implementation
  337.  
  338. uses OleConst;
  339.  
  340. const
  341.   DataFormatCount = 2;
  342.   StreamSignature = $434F4442; {'BDOC'}
  343.  
  344. type
  345.   TStreamHeader = record
  346.     case Integer of
  347.       0: ( { New }
  348.         Signature: Integer;
  349.         DrawAspect: Integer;
  350.         DataSize: Integer);
  351.       1: ( { Old }
  352.         PartRect: TSmallRect);
  353.   end;
  354.  
  355. { Private variables }
  356.  
  357. var
  358.   PixPerInch: TPoint;
  359.   CFObjectDescriptor: Integer;
  360.   CFEmbeddedObject: Integer;
  361.   CFLinkSource: Integer;
  362.   DataFormats: array[0..DataFormatCount - 1] of TFormatEtc;
  363.  
  364. { Return length of PWideChar string }
  365.  
  366. function WStrLen(Str: PWideChar): Integer;
  367. begin
  368.   Result := 0;
  369.   while Str[Result] <> #0 do Inc(Result);
  370. end;
  371.  
  372. { Convert point from pixels to himetric }
  373.  
  374. function PixelsToHimetric(const P: TPoint): TPoint;
  375. begin
  376.   Result.X := MulDiv(P.X, 2540, PixPerInch.X);
  377.   Result.Y := MulDiv(P.Y, 2540, PixPerInch.Y);
  378. end;
  379.  
  380. { Convert point from himetric to pixels }
  381.  
  382. function HimetricToPixels(const P: TPoint): TPoint;
  383. begin
  384.   Result.X := MulDiv(P.X, PixPerInch.X, 2540);
  385.   Result.Y := MulDiv(P.Y, PixPerInch.Y, 2540);
  386. end;
  387.  
  388. { Center the given window on the screen }
  389.  
  390. procedure CenterWindow(Wnd: HWnd);
  391. var
  392.   Rect: TRect;
  393. begin
  394.   GetWindowRect(Wnd, Rect);
  395.   SetWindowPos(Wnd, 0,
  396.     (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
  397.     (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 3,
  398.     0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
  399. end;
  400.  
  401. { Generic dialog hook. Centers the dialog on the screen in response to
  402.   the WM_INITDIALOG message }
  403.  
  404. function OleDialogHook(Wnd: HWnd; Msg, WParam, LParam: Longint): Longint; stdcall;
  405. begin
  406.   Result := 0;
  407.   if Msg = WM_INITDIALOG then
  408.   begin
  409.     if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0 then
  410.       Wnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
  411.     CenterWindow(Wnd);
  412.     Result := 1;
  413.   end;
  414. end;
  415.  
  416. { Destroy a metafile picture }
  417.  
  418. procedure DestroyMetaPict(MetaPict: HGlobal);
  419. begin
  420.   if MetaPict <> 0 then
  421.   begin
  422.     DeleteMetaFile(PMetaFilePict(GlobalLock(MetaPict))^.hMF);
  423.     GlobalUnlock(MetaPict);
  424.     GlobalFree(MetaPict);
  425.   end;
  426. end;
  427.  
  428. { Shade rectangle }
  429.  
  430. procedure ShadeRect(DC: HDC; const Rect: TRect);
  431. const
  432.   HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
  433. var
  434.   Bitmap: HBitmap;
  435.   SaveBrush: HBrush;
  436.   SaveTextColor, SaveBkColor: TColorRef;
  437. begin
  438.   Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  439.   SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  440.   SaveTextColor := SetTextColor(DC, clWhite);
  441.   SaveBkColor := SetBkColor(DC, clBlack);
  442.   with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
  443.   SetBkColor(DC, SaveBkColor);
  444.   SetTextColor(DC, SaveTextColor);
  445.   DeleteObject(SelectObject(DC, SaveBrush));
  446.   DeleteObject(Bitmap);
  447. end;
  448.  
  449. { Return the first piece of a moniker }
  450.  
  451. function OleStdGetFirstMoniker(const Moniker: IMoniker): IMoniker;
  452. var
  453.   Mksys: Longint;
  454.   EnumMoniker: IEnumMoniker;
  455. begin
  456.   Result := nil;
  457.   if Moniker <> nil then
  458.   begin
  459.     if (Moniker.IsSystemMoniker(Mksys) = 0) and
  460.       (Mksys = MKSYS_GENERICCOMPOSITE) then
  461.     begin
  462.       if Moniker.Enum(True, EnumMoniker) <> 0 then Exit;
  463.       EnumMoniker.Next(1, Result, nil);
  464.     end
  465.     else
  466.       Result := Moniker;
  467.   end;
  468. end;
  469.  
  470. { Return length of file moniker piece of the given moniker }
  471.  
  472. function OleStdGetLenFilePrefixOfMoniker(const Moniker: IMoniker): Integer;
  473. var
  474.   MkFirst: IMoniker;
  475.   BindCtx: IBindCtx;
  476.   Mksys: Longint;
  477.   P: PWideChar;
  478. begin
  479.   Result := 0;
  480.   if Moniker <> nil then
  481.   begin
  482.     MkFirst := OleStdGetFirstMoniker(Moniker);
  483.     if (MkFirst <> nil) and
  484.       (MkFirst.IsSystemMoniker(Mksys) = 0) and
  485.       (Mksys = MKSYS_FILEMONIKER) and
  486.       (CreateBindCtx(0, BindCtx) = 0) and
  487.       (MkFirst.GetDisplayName(BindCtx, nil, P) = 0) and (P <> nil) then
  488.     begin
  489.       Result := WStrLen(P);
  490.       CoTaskMemFree(P);
  491.     end;
  492.   end;
  493. end;
  494.  
  495. function CoAllocCStr(const S: string): PChar;
  496. begin
  497.   Result := StrCopy(CoTaskMemAlloc(Length(S) + 1), PChar(S));
  498. end;
  499.  
  500. function GetFullNameStr(const OleObject: IOleObject): string;
  501. var
  502.   P: PWideChar;
  503. begin
  504.   OleObject.GetUserType(USERCLASSTYPE_FULL, P);
  505.   Result := P;
  506.   CoTaskMemFree(P);
  507. end;
  508.  
  509. function GetShortNameStr(const OleObject: IOleObject): string;
  510. var
  511.   P: PWideChar;
  512. begin
  513.   OleObject.GetUserType(USERCLASSTYPE_SHORT, P);
  514.   Result := P;
  515.   CoTaskMemFree(P);
  516. end;
  517.  
  518. function GetDisplayNameStr(const OleLink: IOleLink): string;
  519. var
  520.   P: PWideChar;
  521. begin
  522.   OleLink.GetSourceDisplayName(P);
  523.   Result := P;
  524.   CoTaskMemFree(P);
  525. end;
  526.  
  527. function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
  528. begin
  529.   if Form.OleFormObject = nil then TOleForm.Create(Form);
  530.   Result := Form.OleFormObject as IVCLFrameForm;
  531. end;
  532.  
  533. function IsFormMDIChild(Form: TCustomForm): Boolean;
  534. begin
  535.   Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild);
  536. end;
  537.  
  538. { TOleUILinkInfo - helper interface for Object Properties dialog }
  539.  
  540. type
  541.   TOleUILinkInfo = class(TInterfacedObject, IOleUILinkInfo)
  542.   private
  543.     FContainer: TOleContainer;
  544.     FOleLink: IOleLink;
  545.   public
  546.     constructor Create(Container: TOleContainer);
  547.     function GetNextLink(dwLink: Longint): Longint; stdcall;
  548.     function SetLinkUpdateOptions(dwLink: Longint;
  549.       dwUpdateOpt: Longint): HResult; stdcall;
  550.     function GetLinkUpdateOptions(dwLink: Longint;
  551.       var dwUpdateOpt: Longint): HResult; stdcall;
  552.     function SetLinkSource(dwLink: Longint; pszDisplayName: PChar;
  553.       lenFileName: Longint; var chEaten: Longint;
  554.       fValidateSource: BOOL): HResult; stdcall;
  555.     function GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;
  556.       var lenFileName: Longint; var pszFullLinkType: PChar;
  557.       var pszShortLinkType: PChar; var fSourceAvailable: BOOL;
  558.       var fIsSelected: BOOL): HResult; stdcall;
  559.     function OpenLinkSource(dwLink: Longint): HResult; stdcall;
  560.     function UpdateLink(dwLink: Longint; fErrorMessage: BOOL;
  561.       fErrorAction: BOOL): HResult; stdcall;
  562.     function CancelLink(dwLink: Longint): HResult; stdcall;
  563.     function GetLastUpdate(dwLink: Longint;
  564.       var LastUpdate: TFileTime): HResult; stdcall;
  565.   end;
  566.  
  567. procedure LinkError(const Ident: string);
  568. begin
  569.   Application.MessageBox(PChar(Ident), PChar(SLinkProperties),
  570.     MB_OK or MB_ICONSTOP);
  571. end;
  572.  
  573. constructor TOleUILinkInfo.Create(Container: TOleContainer);
  574. begin
  575.   inherited Create;
  576.   FContainer := Container;
  577.   FContainer.FOleObject.QueryInterface(IOleLink, FOleLink);
  578. end;
  579.  
  580. function TOleUILinkInfo.GetNextLink(dwLink: Longint): Longint;
  581. begin
  582.   if dwLink = 0 then Result := Longint(FContainer) else Result := 0;
  583. end;
  584.  
  585. function TOleUILinkInfo.SetLinkUpdateOptions(dwLink: Longint;
  586.   dwUpdateOpt: Longint): HResult;
  587. begin
  588.   Result := FOleLink.SetUpdateOptions(dwUpdateOpt);
  589.   if Succeeded(Result) then FContainer.Changed;
  590. end;
  591.  
  592. function TOleUILinkInfo.GetLinkUpdateOptions(dwLink: Longint;
  593.   var dwUpdateOpt: Longint): HResult;
  594. begin
  595.   Result := FOleLink.GetUpdateOptions(dwUpdateOpt);
  596. end;
  597.  
  598. function TOleUILinkInfo.SetLinkSource(dwLink: Longint; pszDisplayName: PChar;
  599.   lenFileName: Longint; var chEaten: Longint;
  600.   fValidateSource: BOOL): HResult;
  601. var
  602.   DisplayName: string;
  603.   Buffer: array[0..255] of WideChar;
  604. begin
  605.   Result := E_FAIL;
  606.   if fValidateSource then
  607.   begin
  608.     DisplayName := pszDisplayName;
  609.     if Succeeded(FOleLink.SetSourceDisplayName(StringToWideChar(DisplayName,
  610.       Buffer, SizeOf(Buffer) div 2))) then
  611.     begin
  612.       chEaten := Length(DisplayName);
  613.       try
  614.         FContainer.UpdateObject;
  615.       except
  616.         Application.HandleException(FContainer);
  617.       end;
  618.       Result := S_OK;
  619.     end;
  620.   end else
  621.     LinkError(SInvalidLinkSource);
  622. end;
  623.  
  624. function TOleUILinkInfo.GetLinkSource(dwLink: Longint; var pszDisplayName: PChar;
  625.   var lenFileName: Longint; var pszFullLinkType: PChar;
  626.   var pszShortLinkType: PChar; var fSourceAvailable: BOOL;
  627.   var fIsSelected: BOOL): HResult;
  628. var
  629.   Moniker: IMoniker;
  630. begin
  631.   with FContainer do
  632.   begin
  633.     if @pszDisplayName <> nil then
  634.       pszDisplayName := CoAllocCStr(GetDisplayNameStr(FOleLink));
  635.     if @lenFileName <> nil then
  636.     begin
  637.       lenFileName := 0;
  638.       FOleLink.GetSourceMoniker(Moniker);
  639.       if Moniker <> nil then
  640.         lenFileName := OleStdGetLenFilePrefixOfMoniker(Moniker);
  641.     end;
  642.     if @pszFullLinkType <> nil then
  643.       pszFullLinkType := CoAllocCStr(GetFullNameStr(FOleObject));
  644.     if @pszShortLinkType <> nil then
  645.       pszShortLinkType := CoAllocCStr(GetShortNameStr(FOleObject));
  646.   end;
  647.   Result := S_OK;
  648. end;
  649.  
  650. function TOleUILinkInfo.OpenLinkSource(dwLink: Longint): HResult;
  651. begin
  652.   try
  653.     FContainer.DoVerb(ovShow);
  654.   except
  655.     Application.HandleException(FContainer);
  656.   end;
  657.   Result := S_OK;
  658. end;
  659.  
  660. function TOleUILinkInfo.UpdateLink(dwLink: Longint; fErrorMessage: BOOL;
  661.   fErrorAction: BOOL): HResult;
  662. begin
  663.   try
  664.     FContainer.UpdateObject;
  665.   except
  666.     Application.HandleException(FContainer);
  667.   end;
  668.   Result := S_OK;
  669. end;
  670.  
  671. function TOleUILinkInfo.CancelLink(dwLink: Longint): HResult;
  672. begin
  673.   LinkError(SCannotBreakLink);
  674.   Result := E_NOTIMPL;
  675. end;
  676.  
  677. function TOleUILinkInfo.GetLastUpdate(dwLink: Longint;
  678.   var LastUpdate: TFileTime): HResult;
  679. begin
  680.   Result := S_OK;
  681. end;
  682.  
  683. { TEnumFormatEtc - format enumerator for TDataObject }
  684.  
  685. type
  686.   PFormatList = ^TFormatList;
  687.   TFormatList = array[0..255] of TFormatEtc;
  688.  
  689. type
  690.   TEnumFormatEtc = class(TInterfacedObject, IEnumFormatEtc)
  691.   private
  692.     FFormatList: PFormatList;
  693.     FFormatCount: Integer;
  694.     FIndex: Integer;
  695.   public
  696.     constructor Create(FormatList: PFormatList; FormatCount, Index: Integer);
  697.     { IEnumFormatEtc }
  698.     function Next(celt: Longint; out elt; pceltFetched: PLongint): HResult; stdcall;
  699.     function Skip(celt: Longint): HResult; stdcall;
  700.     function Reset: HResult; stdcall;
  701.     function Clone(out enum: IEnumFormatEtc): HResult; stdcall;
  702.   end;
  703.  
  704. constructor TEnumFormatEtc.Create(FormatList: PFormatList;
  705.   FormatCount, Index: Integer);
  706. begin
  707.   inherited Create;
  708.   FFormatList := FormatList;
  709.   FFormatCount := FormatCount;
  710.   FIndex := Index;
  711. end;
  712.  
  713. function TEnumFormatEtc.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
  714. var
  715.   I: Integer;
  716. begin
  717.   I := 0;
  718.   while (I < celt) and (FIndex < FFormatCount) do
  719.   begin
  720.     TFormatList(elt)[I] := FFormatList[FIndex];
  721.     Inc(FIndex);
  722.     Inc(I);
  723.   end;
  724.   if pceltFetched <> nil then pceltFetched^ := I;
  725.   if I = celt then Result := S_OK else Result := S_FALSE;
  726. end;
  727.  
  728. function TEnumFormatEtc.Skip(celt: Longint): HResult;
  729. begin
  730.   if celt <= FFormatCount - FIndex then
  731.   begin
  732.     FIndex := FIndex + celt;
  733.     Result := S_OK;
  734.   end else
  735.   begin
  736.     FIndex := FFormatCount;
  737.     Result := S_FALSE;
  738.   end;
  739. end;
  740.  
  741. function TEnumFormatEtc.Reset: HResult;
  742. begin
  743.   FIndex := 0;
  744.   Result := S_OK;
  745. end;
  746.  
  747. function TEnumFormatEtc.Clone(out enum: IEnumFormatEtc): HResult;
  748. begin
  749.   enum := TEnumFormatEtc.Create(FFormatList, FFormatCount, FIndex);
  750.   Result := S_OK;
  751. end;
  752.  
  753. { TDataObject - data object for use in clipboard transfers }
  754.  
  755. type
  756.   TDataObject = class(TInterfacedObject, IDataObject)
  757.   private
  758.     FOleObject: IOleObject;
  759.     function GetObjectDescriptor: HGlobal;
  760.   public
  761.     constructor Create(const OleObject: IOleObject);
  762.     { IDataObject }
  763.     function GetData(const formatetcIn: TFormatEtc;
  764.       out medium: TStgMedium): HResult; stdcall;
  765.     function GetDataHere(const formatetc: TFormatEtc;
  766.       out medium: TStgMedium): HResult; stdcall;
  767.     function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
  768.     function GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  769.       out formatetcOut: TFormatEtc): HResult; stdcall;
  770.     function SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  771.       fRelease: BOOL): HResult; stdcall;
  772.     function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
  773.       IEnumFormatEtc): HResult; stdcall;
  774.     function DAdvise(const formatetc: TFormatEtc; advf: Longint;
  775.       const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
  776.     function DUnadvise(dwConnection: Longint): HResult; stdcall;
  777.     function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  778.   end;
  779.  
  780. constructor TDataObject.Create(const OleObject: IOleObject);
  781. begin
  782.   inherited Create;
  783.   FOleObject := OleObject;
  784. end;
  785.  
  786. function TDataObject.GetObjectDescriptor: HGlobal;
  787. var
  788.   DescSize, UTNCharLen, SOCCharLen: Integer;
  789.   Descriptor: PObjectDescriptor;
  790.   UserTypeName, SourceOfCopy: string;
  791.   OleLink: IOleLink;
  792.   P: PWideChar;
  793. begin
  794.   UserTypeName := GetFullNameStr(FOleObject);
  795.   SourceOfCopy := UserTypeName;
  796.   FOleObject.QueryInterface(IOleLink, OleLink);
  797.   if OleLink <> nil then
  798.   begin
  799.     UserTypeName := Format(SLinkedObject, [UserTypeName]);
  800.     SourceOfCopy := GetDisplayNameStr(OleLink);
  801.   end;
  802.   UTNCharLen := MultiByteToWideChar(0, 0, PChar(UserTypeName),
  803.       Length(UserTypeName), nil, 0) + 1;
  804.   SOCCharLen := MultiByteToWideChar(0, 0, PChar(SourceOfCopy),
  805.       Length(SourceOfCopy), nil, 0) + 1;
  806.   DescSize := SizeOf(TObjectDescriptor) +
  807.     ((UTNCharLen + SOCCharLen) * Sizeof(WideChar));
  808.   Result := GlobalAlloc(GMEM_MOVEABLE, DescSize);
  809.   if Result <> 0 then
  810.   begin
  811.     Descriptor := GlobalLock(Result);
  812.     FillChar(Descriptor^, DescSize, 0);
  813.     with Descriptor^ do
  814.     begin
  815.       cbSize := DescSize;
  816.       FOleObject.GetUserClassID(clsid);
  817.       dwDrawAspect := DVASPECT_CONTENT;
  818.       FOleObject.GetMiscStatus(DVASPECT_CONTENT, dwStatus);
  819.  
  820.       dwFullUserTypeName := SizeOf(TObjectDescriptor);
  821.       P := PWideChar(Integer(Descriptor) + dwFullUserTypeName);
  822.       MultiByteToWideChar(0, 0, PChar(UserTypeName), Length(UserTypeName),
  823.         P, UTNCharLen);
  824.       P[UTNCharLen-1] := #0;
  825.  
  826.       dwSrcOfCopy := dwFullUserTypeName + SOCCharLen * SizeOf(WideChar);
  827.       P := PWideChar(Integer(Descriptor) + dwSrcOfCopy);
  828.       MultiByteToWideChar(0, 0, PChar(SourceOfCopy), Length(SourceOfCopy),
  829.         P, SOCCharLen);
  830.       P[SOCCharLen-1] := #0;
  831.     end;
  832.     GlobalUnlock(Result);
  833.   end;
  834. end;
  835.  
  836. function TDataObject.GetData(const formatetcIn: TFormatEtc;
  837.   out medium: TStgMedium): HResult;
  838. var
  839.   Descriptor: HGlobal;
  840. begin
  841.   Result := DV_E_FORMATETC;
  842.   medium.tymed := 0;
  843.   medium.hGlobal := 0;
  844.   medium.unkForRelease := nil;
  845.   with formatetcIn do
  846.   begin
  847.     if (cfFormat = CFObjectDescriptor) and (dwAspect = DVASPECT_CONTENT) and
  848.       (tymed = TYMED_HGLOBAL) then
  849.     begin
  850.       Descriptor := GetObjectDescriptor;
  851.       if Descriptor <> 0 then
  852.       begin
  853.         medium.tymed := TYMED_HGLOBAL;
  854.         medium.hGlobal := Descriptor;
  855.         Result := S_OK;
  856.       end;
  857.     end;
  858.   end;
  859. end;
  860.  
  861. function TDataObject.GetDataHere(const formatetc: TFormatEtc;
  862.   out medium: TStgMedium): HResult;
  863. var
  864.   PersistStorage: IPersistStorage;
  865. begin
  866.   Result := DV_E_FORMATETC;
  867.   with formatetc do
  868.     if (cfFormat = CFEmbeddedObject) and (dwAspect = DVASPECT_CONTENT) and
  869.       (tymed = TYMED_ISTORAGE) then
  870.     begin
  871.       medium.unkForRelease := nil;
  872.       FOleObject.QueryInterface(IPersistStorage, PersistStorage);
  873.       if PersistStorage <> nil then
  874.       begin
  875.         Result := OleSave(PersistStorage, IStorage(medium.stg), False);
  876.         PersistStorage.SaveCompleted(nil);
  877.       end;
  878.     end;
  879. end;
  880.  
  881. function TDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;
  882. begin
  883.   Result := DV_E_FORMATETC;
  884.   with formatetc do
  885.     if dwAspect = DVASPECT_CONTENT then
  886.       if (cfFormat = CFEmbeddedObject) and (tymed = TYMED_ISTORAGE) or
  887.         (cfFormat = CFObjectDescriptor) and (tymed = TYMED_HGLOBAL) then
  888.         Result := S_OK;
  889. end;
  890.  
  891. function TDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
  892.   out formatetcOut: TFormatEtc): HResult;
  893. begin
  894.   formatetcOut.ptd := nil;
  895.   Result := E_NOTIMPL;
  896. end;
  897.  
  898. function TDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
  899.   fRelease: BOOL): HResult;
  900. begin
  901.   Result := E_NOTIMPL;
  902. end;
  903.  
  904. function TDataObject.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
  905.   IEnumFormatEtc): HResult;
  906. begin
  907.   if dwDirection = DATADIR_GET then
  908.   begin
  909.     enumFormatEtc := TEnumFormatEtc.Create(@DataFormats, DataFormatCount, 0);
  910.     Result := S_OK;
  911.   end else
  912.   begin
  913.     enumFormatEtc := nil;
  914.     Result := E_NOTIMPL;
  915.   end;
  916. end;
  917.  
  918. function TDataObject.DAdvise(const formatetc: TFormatEtc; advf: Longint;
  919.   const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  920. begin
  921.   Result := OLE_E_ADVISENOTSUPPORTED;
  922. end;
  923.  
  924. function TDataObject.DUnadvise(dwConnection: Longint): HResult;
  925. begin
  926.   Result := OLE_E_ADVISENOTSUPPORTED;
  927. end;
  928.  
  929. function TDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
  930. begin
  931.   Result := OLE_E_ADVISENOTSUPPORTED;
  932. end;
  933.  
  934. { TOleContainer.IOleUIObjInfo - helper interface for Object Properties dialog }
  935.  
  936. function TOleContainer.GetObjectInfo(dwObject: Longint;
  937.   var dwObjSize: Longint; var lpszLabel: PChar;
  938.   var lpszType: PChar; var lpszShortType: PChar;
  939.   var lpszLocation: PChar): HResult;
  940. begin
  941.   if @dwObjSize <> nil then
  942.     dwObjSize := GetObjectDataSize;
  943.   if @lpszLabel <> nil then
  944.     lpszLabel := CoAllocCStr(GetFullNameStr(FOleObject));
  945.   if @lpszType <> nil then
  946.     lpszType := CoAllocCStr(GetFullNameStr(FOleObject));
  947.   if @lpszShortType <> nil then
  948.     lpszShortType := CoAllocCStr(GetShortNameStr(FOleObject));
  949.   if @lpszLocation <> nil then
  950.     lpszLocation := CoAllocCStr(Caption);
  951.   Result := S_OK;
  952. end;
  953.  
  954. function TOleContainer.GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;
  955.   var wFormat: Word; var ConvertDefaultClassID: TCLSID;
  956.   var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult;
  957. begin
  958.   FOleObject.GetUserClassID(ClassID);
  959.   Result := S_OK;
  960. end;
  961.  
  962. function TOleContainer.ConvertObject(dwObject: Longint;
  963.   const clsidNew: TCLSID): HResult;
  964. begin
  965.   Result := E_NOTIMPL;
  966. end;
  967.  
  968. function TOleContainer.GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal;
  969.   var dvAspect: Longint; var nCurrentScale: Integer): HResult;
  970. begin
  971.   if @hMetaPict <> nil then hMetaPict := GetIconMetaPict;
  972.   if @dvAspect <> nil then dvAspect := FDrawAspect;
  973.   if @nCurrentScale <> nil then nCurrentScale := 0;
  974.   Result := S_OK;
  975. end;
  976.  
  977. function TOleContainer.SetViewInfo(dwObject: Longint; hMetaPict: HGlobal;
  978.   dvAspect: Longint; nCurrentScale: Integer;
  979.   bRelativeToOrig: BOOL): HResult;
  980. var
  981.   ShowAsIcon: Boolean;
  982. begin
  983.   case dvAspect of
  984.     DVASPECT_CONTENT: ShowAsIcon := False;
  985.     DVASPECT_ICON: ShowAsIcon := True;
  986.   else
  987.     ShowAsIcon := Iconic;
  988.   end;
  989.   SetDrawAspect(ShowAsIcon, hMetaPict);
  990.   Result := S_OK;
  991. end;
  992.  
  993. { TOleContainer.IOleClientSite }
  994.  
  995. function TOleContainer.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  996.   out mk: IMoniker): HResult;
  997. begin
  998.   mk := nil;
  999.   Result := E_NOTIMPL;
  1000. end;
  1001.  
  1002. function TOleContainer.GetContainer(out container: IOleContainer): HResult;
  1003. begin
  1004.   container := nil;
  1005.   Result := E_NOINTERFACE;
  1006. end;
  1007.  
  1008. function TOleContainer.ShowObject: HResult;
  1009. begin
  1010.   Result := S_OK;
  1011. end;
  1012.  
  1013. function TOleContainer.OnShowWindow(fShow: BOOL): HResult;
  1014. begin
  1015.   if FObjectOpen <> Boolean(fShow) then
  1016.   begin
  1017.     FObjectOpen := fShow;
  1018.     Invalidate;
  1019.   end;
  1020.   Result := S_OK;
  1021. end;
  1022.  
  1023. function TOleContainer.RequestNewObjectLayout: HResult;
  1024. begin
  1025.   Result := E_NOTIMPL;
  1026. end;
  1027.  
  1028. { TOleContainer.IOleInPlaceSite }
  1029.  
  1030. function TOleContainer.GetWindow(out wnd: HWnd): HResult;
  1031. begin
  1032.   if FDocObj then
  1033.     wnd := Handle
  1034.   else
  1035.     wnd := Parent.Handle;
  1036.   Result := S_OK;
  1037. end;
  1038.  
  1039. function TOleContainer.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  1040. begin
  1041.   Result := S_OK;
  1042. end;
  1043.  
  1044. function TOleContainer.CanInPlaceActivate: HResult;
  1045. begin
  1046.   Result := S_FALSE;
  1047.   if not (csDesigning in ComponentState) and Visible and
  1048.     AllowInPlace and not Iconic then
  1049.     Result := S_OK;
  1050. end;
  1051.  
  1052. function TOleContainer.OnInPlaceActivate: HResult;
  1053. begin
  1054.   FOleObject.QueryInterface(IOleInPlaceObject, FOleInPlaceObject);
  1055.   FOleObject.QueryInterface(IOleInPlaceActiveObject, FOleInPlaceActiveObject);
  1056.   Result := S_OK;
  1057. end;
  1058.  
  1059. function TOleContainer.OnUIActivate: HResult;
  1060. begin
  1061.   SetUIActive(True);
  1062.   Result := S_OK;
  1063. end;
  1064.  
  1065. function TOleContainer.GetWindowContext(out frame: IOleInPlaceFrame;
  1066.   out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
  1067.   out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
  1068. var
  1069.   Origin: TPoint;
  1070. begin
  1071.   frame := FFrameForm;
  1072.   doc := nil;
  1073.   if FDocObj then
  1074.   begin
  1075.     rcPosRect := Rect(0,0,Width,Height);
  1076.     rcClipRect := rcPosRect;
  1077.   end
  1078.   else
  1079.   begin
  1080.     Origin := Parent.ScreenToClient(ClientOrigin);
  1081.     SetRect(rcPosRect, Origin.X, Origin.Y,
  1082.       Origin.X + ClientWidth, Origin.Y + ClientHeight);
  1083.       SetRect(rcClipRect, -16384, -16384, 16383, 16383);
  1084.   end;
  1085.   CreateAccelTable;
  1086.   with frameInfo do
  1087.   begin
  1088.     fMDIApp := False;
  1089.     FFrameForm.GetWindow(hWndFrame);
  1090.     hAccel := FAccelTable;
  1091.     cAccelEntries := FAccelCount;
  1092.   end;
  1093.   Result := S_OK;
  1094. end;
  1095.  
  1096. function TOleContainer.Scroll(scrollExtent: TPoint): HResult;
  1097. begin
  1098.   Result := E_NOTIMPL;
  1099. end;
  1100.  
  1101. function TOleContainer.OnUIDeactivate(fUndoable: BOOL): HResult;
  1102. begin
  1103.   FFrameForm.SetMenu(0, 0, 0);
  1104.   FFrameForm.ClearBorderSpace;
  1105.   SetUIActive(False);
  1106.   Result := S_OK;
  1107. end;
  1108.  
  1109. function TOleContainer.OnInPlaceDeactivate: HResult;
  1110. begin
  1111.   FOleInPlaceActiveObject := nil;
  1112.   FOleInPlaceObject := nil;
  1113.   Result := S_OK;
  1114. end;
  1115.  
  1116. function TOleContainer.DiscardUndoState: HResult;
  1117. begin
  1118.   Result := E_NOTIMPL;
  1119. end;
  1120.  
  1121. function TOleContainer.DeactivateAndUndo: HResult;
  1122. begin
  1123.   FOleInPlaceObject.UIDeactivate;
  1124.   Result := S_OK;
  1125. end;
  1126.  
  1127. function TOleContainer.OnPosRectChange(const rcPosRect: TRect): HResult;
  1128. begin
  1129.   try
  1130.     ObjectMoved(rcPosRect);
  1131.     UpdateObjectRect;
  1132.   except
  1133.     Application.HandleException(Self);
  1134.   end;
  1135.   Result := S_OK;
  1136. end;
  1137.  
  1138. { TOleContainer.IAdviseSink }
  1139.  
  1140. procedure TOleContainer.OnDataChange(const formatetc: TFormatEtc;
  1141.   const stgmed: TStgMedium);
  1142. begin
  1143.   Changed;
  1144. end;
  1145.  
  1146. procedure TOleContainer.OnViewChange(dwAspect: Longint; lindex: Longint);
  1147. begin
  1148.   if dwAspect = FDrawAspect then UpdateView;
  1149. end;
  1150.  
  1151. procedure TOleContainer.OnRename(const mk: IMoniker);
  1152. begin
  1153. end;
  1154.  
  1155. procedure TOleContainer.OnSave;
  1156. begin
  1157. end;
  1158.  
  1159. procedure TOleContainer.OnClose;
  1160. begin
  1161. end;
  1162.  
  1163. { TOleContainer.IOleDocumentSite }
  1164.  
  1165. function TOleContainer.ActivateMe(View: IOleDocumentView): HRESULT;
  1166. var
  1167.   Doc: IOleDocument;
  1168. begin
  1169.   Result := E_FAIL;
  1170.   if View = nil then
  1171.   begin   // If we're given a nil view, try to get one from the document object.
  1172.     if FOleObject.QueryInterface(IOleDocument, Doc) <> 0 then Exit;
  1173.     if Doc = nil then Exit;
  1174.     Result := Doc.CreateView(Self, nil, 0, View);
  1175.     if Result <> 0 then Exit;
  1176.   end
  1177.   else
  1178.     View.SetInPlaceSite(Self);
  1179.  
  1180.   FDocObj := True;
  1181.   FDocView := View;
  1182.   View.UIActivate(TRUE);    //Set up toolbars and menus first
  1183.   UpdateObjectRect;         //Then set window size, after toolbars
  1184.   View.Show(TRUE);
  1185.   Result := NOERROR;
  1186. end;
  1187.  
  1188. { TOleContainer }
  1189.  
  1190. constructor TOleContainer.Create(AOwner: TComponent);
  1191. const
  1192.   ContainerStyle = [csClickEvents, csSetCaption, csOpaque, csDoubleClicks];
  1193. begin
  1194.   inherited Create(AOwner);
  1195.   FRefCount := 1;
  1196.   if NewStyleControls then
  1197.     ControlStyle := ContainerStyle else
  1198.     ControlStyle := ContainerStyle + [csFramed];
  1199.   Width := 121;
  1200.   Height := 121;
  1201.   TabStop := True;
  1202.   ParentColor := False;
  1203.   FAllowInPlace := True;
  1204.   FAllowActiveDoc := True;
  1205.   FAutoActivate := aaDoubleClick;
  1206.   FAutoVerbMenu := True;
  1207.   FBorderStyle := bsSingle;
  1208.   FCopyOnSave := True;
  1209.   FDrawAspect := DVASPECT_CONTENT;
  1210. end;
  1211.  
  1212. destructor TOleContainer.Destroy;
  1213. begin
  1214.   DestroyObject;
  1215.   inherited Destroy;
  1216. end;
  1217.  
  1218. function TOleContainer._AddRef: Integer;
  1219. begin
  1220.   Inc(FRefCount);
  1221.   Result := FRefCount;
  1222. end;
  1223.  
  1224. procedure TOleContainer.AdjustBounds;
  1225. var
  1226.   Size: TPoint;
  1227.   Extra: Integer;
  1228. begin
  1229.   if not (csReading in ComponentState) and (FSizeMode = smAutoSize) and
  1230.     (FOleObject <> nil) then
  1231.   begin
  1232.     Size := HimetricToPixels(FViewSize);
  1233.     Extra := GetBorderWidth * 2;
  1234.     SetBounds(Left, Top, Size.X + Extra, Size.Y + Extra);
  1235.   end;
  1236. end;
  1237.  
  1238. function TOleContainer.ChangeIconDialog: Boolean;
  1239. var
  1240.   Data: TOleUIChangeIcon;
  1241. begin
  1242.   CheckObject;
  1243.   Result := False;
  1244.   FillChar(Data, SizeOf(Data), 0);
  1245.   Data.cbStruct := SizeOf(Data);
  1246.   Data.dwFlags := CIF_SELECTCURRENT;
  1247.   Data.hWndOwner := Application.Handle;
  1248.   Data.lpfnHook := OleDialogHook;
  1249.   OleCheck(FOleObject.GetUserClassID(Data.clsid));
  1250.   Data.hMetaPict := GetIconMetaPict;
  1251.   try
  1252.     if OleUIChangeIcon(Data) = OLEUI_OK then
  1253.     begin
  1254.       SetDrawAspect(True, Data.hMetaPict);
  1255.       Result := True;
  1256.     end;
  1257.   finally
  1258.     DestroyMetaPict(Data.hMetaPict);
  1259.   end;
  1260. end;
  1261.  
  1262. procedure TOleContainer.CheckObject;
  1263. begin
  1264.   if FOleObject = nil then
  1265.     raise EOleError.CreateRes(@SEmptyContainer);
  1266. end;
  1267.  
  1268. procedure TOleContainer.Close;
  1269. begin
  1270.   CheckObject;
  1271.   OleCheck(FOleObject.Close(OLECLOSE_SAVEIFDIRTY));
  1272. end;
  1273.  
  1274. procedure TOleContainer.Copy;
  1275. begin
  1276.   Close;
  1277.   OleCheck(OleSetClipboard(TDataObject.Create(FOleObject) as IDataObject));
  1278. end;
  1279.  
  1280. procedure TOleContainer.CreateAccelTable;
  1281. var
  1282.   Menu: TMainMenu;
  1283. begin
  1284.   if FAccelTable = 0 then
  1285.   begin
  1286.     Menu := FFrameForm.Form.Menu;
  1287.     if Menu <> nil then
  1288.       Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]);
  1289.   end;
  1290. end;
  1291.  
  1292. procedure TOleContainer.CreateLinkToFile(const FileName: string;
  1293.   Iconic: Boolean);
  1294. var
  1295.   CreateInfo: TCreateInfo;
  1296. begin
  1297.   CreateInfo.CreateType := ctLinkToFile;
  1298.   CreateInfo.ShowAsIcon := Iconic;
  1299.   CreateInfo.IconMetaPict := 0;
  1300.   CreateInfo.FileName := FileName;
  1301.   CreateObjectFromInfo(CreateInfo);
  1302. end;
  1303.  
  1304. procedure TOleContainer.CreateObject(const OleClassName: string;
  1305.   Iconic: Boolean);
  1306. var
  1307.   CreateInfo: TCreateInfo;
  1308. begin
  1309.   CreateInfo.CreateType := ctNewObject;
  1310.   CreateInfo.ShowAsIcon := Iconic;
  1311.   CreateInfo.IconMetaPict := 0;
  1312.   CreateInfo.ClassID := ProgIDToClassID(OleClassName);
  1313.   CreateObjectFromInfo(CreateInfo);
  1314. end;
  1315.  
  1316. procedure TOleContainer.CreateObjectFromFile(const FileName: string;
  1317.   Iconic: Boolean);
  1318. var
  1319.   CreateInfo: TCreateInfo;
  1320. begin
  1321.   CreateInfo.CreateType := ctFromFile;
  1322.   CreateInfo.ShowAsIcon := Iconic;
  1323.   CreateInfo.IconMetaPict := 0;
  1324.   CreateInfo.FileName := FileName;
  1325.   CreateObjectFromInfo(CreateInfo);
  1326. end;
  1327.  
  1328. procedure TOleContainer.CreateObjectFromInfo(const CreateInfo: TCreateInfo);
  1329. begin
  1330.   DestroyObject;
  1331.   try
  1332.     CreateStorage;
  1333.     with CreateInfo do
  1334.     begin
  1335.       case CreateType of
  1336.         ctNewObject:
  1337.           OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil,
  1338.             Self, FStorage, FOleObject));
  1339.         ctFromFile:
  1340.           OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(FileName), IOleObject,
  1341.             OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
  1342.         ctLinkToFile:
  1343.           OleCheck(OleCreateLinkToFile(PWideChar(FileName), IOleObject,
  1344.             OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
  1345.         ctFromData:
  1346.           OleCheck(OleCreateFromData(DataObject, IOleObject,
  1347.             OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
  1348.         ctLinkFromData:
  1349.           OleCheck(OleCreateLinkFromData(DataObject, IOleObject,
  1350.             OLERENDER_DRAW, nil, Self, FStorage, FOleObject));
  1351.       end;
  1352.       FDrawAspect := DVASPECT_CONTENT;
  1353.       InitObject;
  1354.       FOleObject.SetExtent(DVASPECT_CONTENT, PixelsToHimetric(
  1355.         Point(ClientWidth, ClientHeight)));
  1356.       SetDrawAspect(ShowAsIcon, IconMetaPict);
  1357.       UpdateView;
  1358.     end;
  1359.   except
  1360.     DestroyObject;
  1361.     raise;
  1362.   end;
  1363. end;
  1364.  
  1365. procedure TOleContainer.CreateParams(var Params: TCreateParams);
  1366. begin
  1367.   inherited CreateParams(Params);
  1368.   with Params do
  1369.   begin
  1370.     Style := Style or WS_CLIPCHILDREN;
  1371.     WindowClass.Style := WindowClass.Style and not (CS_HREDRAW or CS_VREDRAW);
  1372.   end;
  1373. end;
  1374.  
  1375. procedure TOleContainer.CreateStorage;
  1376. begin
  1377.   OleCheck(CreateILockBytesOnHGlobal(0, True, FLockBytes));
  1378.   OleCheck(StgCreateDocfileOnILockBytes(FLockBytes, STGM_READWRITE
  1379.     or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, FStorage));
  1380. end;
  1381.  
  1382. procedure TOleContainer.DblClick;
  1383. begin
  1384.   if FAutoActivate = aaDoubleClick then
  1385.     DoVerb(ovPrimary)
  1386.   else
  1387.     inherited;
  1388. end;
  1389.  
  1390. procedure TOleContainer.DefineProperties(Filer: TFiler);
  1391. begin
  1392.   inherited DefineProperties(Filer);
  1393.   Filer.DefineBinaryProperty('Data', LoadFromStream, SaveToStream,
  1394.     FOleObject <> nil);
  1395. end;
  1396.  
  1397. procedure TOleContainer.DesignModified;
  1398. var
  1399.   Form: TCustomForm;
  1400. begin
  1401.   Form := GetParentForm(Self);
  1402.   if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1403. end;
  1404.  
  1405. procedure TOleContainer.DestroyAccelTable;
  1406. begin
  1407.   if FAccelTable <> 0 then
  1408.   begin
  1409.     DestroyAcceleratorTable(FAccelTable);
  1410.     FAccelTable := 0;
  1411.     FAccelCount := 0;
  1412.   end;
  1413. end;
  1414.  
  1415. procedure TOleContainer.DestroyObject;
  1416. var
  1417.   DataObject: IDataObject;
  1418. begin
  1419.   if FOleObject <> nil then
  1420.   begin
  1421.     SetViewAdviseSink(False);
  1422.     if FDataConnection <> 0 then
  1423.     begin
  1424.       FOleObject.QueryInterface(IDataObject, DataObject);
  1425.       if DataObject <> nil then
  1426.       begin
  1427.         DataObject.DUnadvise(FDataConnection);
  1428.         DataObject := nil;
  1429.       end;
  1430.       FDataConnection := 0;
  1431.     end;
  1432.     FOleObject.Close(OLECLOSE_NOSAVE);
  1433.     Invalidate;
  1434.     Changed;
  1435.   end;
  1436.   FDocView := nil;
  1437.   FOleObject := nil;
  1438.   FStorage := nil;
  1439.   FLockBytes := nil;
  1440.   DestroyVerbs;
  1441.   DestroyAccelTable;
  1442.   if FDocForm <> nil then
  1443.   begin
  1444.     if FFrameForm <> FDocForm then FFrameForm.RemoveContainer(Self);
  1445.     FDocForm.RemoveContainer(Self);
  1446.     FFrameForm := nil;
  1447.     FDocForm := nil;
  1448.   end;
  1449. end;
  1450.  
  1451. procedure TOleContainer.DestroyVerbs;
  1452. begin
  1453.   FPopupVerbMenu.Free;
  1454.   FPopupVerbMenu := nil;
  1455.   FObjectVerbs.Free;
  1456.   FObjectVerbs := nil;
  1457. end;
  1458.  
  1459. procedure TOleContainer.DoEnter;
  1460. begin
  1461.   if FAutoActivate = aaGetFocus then DoVerb(ovShow);
  1462.   inherited;
  1463. end;
  1464.  
  1465. procedure TOleContainer.DoVerb(Verb: Integer);
  1466. var
  1467.   H: THandle;
  1468.   R: TRect;
  1469. begin
  1470.   CheckObject;
  1471.   if Verb > 0 then
  1472.   begin
  1473.     if FObjectVerbs = nil then UpdateVerbs;
  1474.     if Verb >= FObjectVerbs.Count then
  1475.       raise EOleError.CreateRes(@SInvalidVerb);
  1476.     Verb := Smallint(Integer(FObjectVerbs.Objects[Verb]) and $0000FFFF);
  1477.   end else
  1478.     if Verb = ovPrimary then Verb := 0;
  1479.   if FDocObj then
  1480.   begin
  1481.     R := ClientRect;
  1482.     H := Handle;
  1483.   end
  1484.   else
  1485.   begin
  1486.     R := BoundsRect;
  1487.     H := Parent.Handle;
  1488.   end;
  1489.   OleCheck(FOleObject.DoVerb(Verb, nil, Self, 0, H, R));
  1490. end;
  1491.  
  1492. function TOleContainer.GetBorderWidth: Integer;
  1493. begin
  1494.   if FBorderStyle = bsNone then
  1495.     Result := 0
  1496.   else
  1497.     if NewStyleControls and Ctl3D then
  1498.       Result := 2
  1499.     else
  1500.       Result := 1;
  1501. end;
  1502.  
  1503. function TOleContainer.GetCanPaste: Boolean;
  1504. var
  1505.   DataObject: IDataObject;
  1506. begin
  1507.   Result := Succeeded(OleGetClipboard(DataObject)) and
  1508.     ((OleQueryCreateFromData(DataObject) = 0) or
  1509.      (OleQueryLinkFromData(DataObject) = 0));
  1510. end;
  1511.  
  1512. function TOleContainer.GetIconic: Boolean;
  1513. begin
  1514.   Result := FDrawAspect = DVASPECT_ICON;
  1515. end;
  1516.  
  1517. function TOleContainer.GetIconMetaPict: HGlobal;
  1518. var
  1519.   DataObject: IDataObject;
  1520.   FormatEtc: TFormatEtc;
  1521.   Medium: TStgMedium;
  1522.   ClassID: TCLSID;
  1523. begin
  1524.   CheckObject;
  1525.   Result := 0;
  1526.   if FDrawAspect = DVASPECT_ICON then
  1527.   begin
  1528.     FOleObject.QueryInterface(IDataObject, DataObject);
  1529.     if DataObject <> nil then
  1530.     begin
  1531.       FormatEtc.cfFormat := CF_METAFILEPICT;
  1532.       FormatEtc.ptd := nil;
  1533.       FormatEtc.dwAspect := DVASPECT_ICON;
  1534.       FormatEtc.lIndex := -1;
  1535.       FormatEtc.tymed := TYMED_MFPICT;
  1536.       if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
  1537.         Result := Medium.hMetaFilePict;
  1538.     end;
  1539.   end;
  1540.   if Result = 0 then
  1541.   begin
  1542.     OleCheck(FOleObject.GetUserClassID(ClassID));
  1543.     Result := OleGetIconOfClass(ClassID, nil, True);
  1544.   end;
  1545. end;
  1546.  
  1547. function TOleContainer.GetLinked: Boolean;
  1548. var
  1549.   OleLink: IOleLink;
  1550. begin
  1551.   CheckObject;
  1552.   FOleObject.QueryInterface(IOleLink, OleLink);
  1553.   Result := (OleLink <> nil);
  1554. end;
  1555.  
  1556. function TOleContainer.GetObjectDataSize: Integer;
  1557. var
  1558.   DataHandle: HGlobal;
  1559. begin
  1560.   if Succeeded(GetHGlobalFromILockBytes(FLockBytes, DataHandle)) then
  1561.     Result := GlobalSize(DataHandle) else
  1562.     Result := 0;
  1563. end;
  1564.  
  1565. function TOleContainer.GetObjectVerbs: TStrings;
  1566. begin
  1567.   if FObjectVerbs = nil then UpdateVerbs;
  1568.   Result := FObjectVerbs;
  1569. end;
  1570.  
  1571. function TOleContainer.GetOleClassName: string;
  1572. var
  1573.   ClassID: TCLSID;
  1574. begin
  1575.   CheckObject;
  1576.   OleCheck(FOleObject.GetUserClassID(ClassID));
  1577.   Result := ClassIDToProgID(ClassID);
  1578. end;
  1579.  
  1580. function TOleContainer.GetOleObject: Variant;
  1581. begin
  1582.   CheckObject;
  1583.   Result := Variant(FOleObject as IDispatch);
  1584. end;
  1585.  
  1586. function TOleContainer.GetPopupMenu: TPopupMenu;
  1587. var
  1588.   I: Integer;
  1589.   Item: TMenuItem;
  1590. begin
  1591.   if FAutoVerbMenu and (FOleObject <> nil) and (ObjectVerbs.Count > 0) then
  1592.   begin
  1593.     if FPopupVerbMenu = nil then
  1594.     begin
  1595.       FPopupVerbMenu := TPopupMenu.Create(Self);
  1596.       for I := 0 to ObjectVerbs.Count - 1 do
  1597.       begin
  1598.         Item := TMenuItem.Create(Self);
  1599.         Item.Caption := ObjectVerbs[I];
  1600.         Item.Tag := I;
  1601.         Item.OnClick := PopupVerbMenuClick;
  1602.         FPopupVerbMenu.Items.Add(Item);
  1603.       end;
  1604.     end;
  1605.     Result := FPopupVerbMenu;
  1606.   end else
  1607.     Result := inherited GetPopupMenu;
  1608. end;
  1609.  
  1610. function TOleContainer.GetPrimaryVerb: Integer;
  1611. begin
  1612.   if FObjectVerbs = nil then UpdateVerbs;
  1613.   for Result := 0 to FObjectVerbs.Count - 1 do
  1614.     if Integer(FObjectVerbs.Objects[Result]) and $0000FFFF = 0 then Exit;
  1615.   Result := 0;
  1616. end;
  1617.  
  1618. function TOleContainer.GetSourceDoc: string;
  1619. var
  1620.   OleLink: IOleLink;
  1621. begin
  1622.   CheckObject;
  1623.   Result := '';
  1624.   FOleObject.QueryInterface(IOleLink, OleLink);
  1625.   if OleLink <> nil then
  1626.     Result := GetDisplayNameStr(OleLink);
  1627. end;
  1628.  
  1629. function TOleContainer.GetState: TObjectState;
  1630. begin
  1631.   if FOleObject = nil then
  1632.     Result := osEmpty
  1633.   else if FObjectOpen then
  1634.     Result := osOpen
  1635.   else if FUIActive then
  1636.     Result := osUIActive
  1637.   else if OleIsRunning(FOleObject) then
  1638.     Result := osRunning
  1639.   else
  1640.     Result := osLoaded;
  1641. end;
  1642.  
  1643. procedure TOleContainer.InitObject;
  1644. var
  1645.   DataObject: IDataObject;
  1646.   FormatEtc: TFormatEtc;
  1647. begin
  1648.   FDocForm := GetVCLFrameForm(ValidParentForm(Self));
  1649.   FFrameForm := FDocForm;
  1650.   FDocForm.AddContainer(Self);
  1651.   if IsFormMDIChild(FDocForm.Form) then
  1652.   begin
  1653.     FFrameForm := GetVCLFrameForm(Application.MainForm);
  1654.     FFrameForm.AddContainer(Self);
  1655.   end;
  1656.   SetViewAdviseSink(True);
  1657.   FOleObject.SetHostNames(PWideChar(WideString(Application.Title)),
  1658.     PWideChar(WideString(Caption)));
  1659.   OleSetContainedObject(FOleObject, True);
  1660.   FOleObject.QueryInterface(IDataObject, DataObject);
  1661.   if DataObject <> nil then
  1662.   begin
  1663.     FormatEtc.cfFormat := 0;
  1664.     FormatEtc.ptd := nil;
  1665.     FormatEtc.dwAspect := -1;
  1666.     FormatEtc.lIndex := -1;
  1667.     FormatEtc.tymed := -1;
  1668.     DataObject.DAdvise(FormatEtc, ADVF_NODATA, Self, FDataConnection);
  1669.   end;
  1670. end;
  1671.  
  1672. function TOleContainer.InsertObjectDialog: Boolean;
  1673. var
  1674.   Data: TOleUIInsertObject;
  1675.   NameBuffer: array[0..255] of Char;
  1676.   CreateInfo: TCreateInfo;
  1677. begin
  1678.   Result := False;
  1679.   FNewInserted := False;
  1680.   FillChar(Data, SizeOf(Data), 0);
  1681.   FillChar(NameBuffer, SizeOf(NameBuffer), 0);
  1682.   Data.cbStruct := SizeOf(Data);
  1683.   Data.dwFlags := IOF_SELECTCREATENEW;
  1684.   Data.hWndOwner := Application.Handle;
  1685.   Data.lpfnHook := OleDialogHook;
  1686.   Data.lpszFile := NameBuffer;
  1687.   Data.cchFile := SizeOf(NameBuffer);
  1688.   try
  1689.     if OleUIInsertObject(Data) = OLEUI_OK then
  1690.     begin
  1691.       if Data.dwFlags and IOF_SELECTCREATENEW <> 0 then
  1692.       begin
  1693.         CreateInfo.CreateType := ctNewObject;
  1694.         CreateInfo.ClassID := Data.clsid;
  1695.       end else
  1696.       begin
  1697.         if Data.dwFlags and IOF_CHECKLINK = 0 then
  1698.           CreateInfo.CreateType := ctFromFile else
  1699.           CreateInfo.CreateType := ctLinkToFile;
  1700.         CreateInfo.FileName := NameBuffer;
  1701.       end;
  1702.       CreateInfo.ShowAsIcon := Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0;
  1703.       CreateInfo.IconMetaPict := Data.hMetaPict;
  1704.       CreateObjectFromInfo(CreateInfo);
  1705.       if CreateInfo.CreateType = ctNewObject then FNewInserted := True;
  1706.       Result := True;
  1707.     end;
  1708.   finally
  1709.     DestroyMetaPict(Data.hMetaPict);
  1710.   end;
  1711. end;
  1712.  
  1713. procedure TOleContainer.KeyDown(var Key: Word; Shift: TShiftState);
  1714. begin
  1715.   inherited KeyDown(Key, Shift);
  1716.   if (FAutoActivate <> aaManual) and (Key = VK_RETURN) then
  1717.   begin
  1718.     if ssCtrl in Shift then DoVerb(ovShow) else DoVerb(ovPrimary);
  1719.     Key := 0;
  1720.   end;
  1721. end;
  1722.  
  1723. procedure TOleContainer.LoadFromFile(const FileName: string);
  1724. var
  1725.   Stream: TStream;
  1726. begin
  1727.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1728.   try
  1729.     LoadFromStream(Stream);
  1730.   finally
  1731.     Stream.Free;
  1732.   end;
  1733. end;
  1734.  
  1735. procedure TOleContainer.LoadFromStream(Stream: TStream);
  1736. var
  1737.   DataHandle: HGlobal;
  1738.   Buffer: Pointer;
  1739.   Header: TStreamHeader;
  1740. begin
  1741.   DestroyObject;
  1742.   Stream.ReadBuffer(Header, SizeOf(Header));
  1743.   if (Header.Signature <> StreamSignature) and not FOldStreamFormat then
  1744.     raise EOleError.CreateRes(@SInvalidStreamFormat);
  1745.   DataHandle := GlobalAlloc(GMEM_MOVEABLE, Header.DataSize);
  1746.   if DataHandle = 0 then OutOfMemoryError;
  1747.   try
  1748.     Buffer := GlobalLock(DataHandle);
  1749.     try
  1750.       Stream.Read(Buffer^, Header.DataSize);
  1751.     finally
  1752.       GlobalUnlock(DataHandle);
  1753.     end;
  1754.     OleCheck(CreateILockBytesOnHGlobal(DataHandle, True, FLockBytes));
  1755.     DataHandle := 0;
  1756.     OleCheck(StgOpenStorageOnILockBytes(FLockBytes, nil, STGM_READWRITE or
  1757.       STGM_SHARE_EXCLUSIVE, nil, 0, FStorage));
  1758.     OleCheck(OleLoad(FStorage, IOleObject, Self, FOleObject));
  1759.     FDrawAspect := Header.DrawAspect;
  1760.     InitObject;
  1761.     UpdateView;
  1762.   except
  1763.     if DataHandle <> 0 then GlobalFree(DataHandle);
  1764.     DestroyObject;
  1765.     raise;
  1766.   end;
  1767. end;
  1768.  
  1769. procedure TOleContainer.MouseDown(Button: TMouseButton;
  1770.   Shift: TShiftState; X, Y: Integer);
  1771. begin
  1772.   if Button = mbLeft then SetFocus;
  1773.   inherited MouseDown(Button, Shift, X, Y);
  1774. end;
  1775.  
  1776. procedure TOleContainer.Changed;
  1777. begin
  1778.   if not (csReading in ComponentState) then
  1779.   begin
  1780.     FModified := True;
  1781.     FModSinceSave := True;
  1782.     DesignModified;
  1783.   end;
  1784. end;
  1785.  
  1786. procedure TOleContainer.ObjectMoved(const ObjectRect: TRect);
  1787. var
  1788.   R: TRect;
  1789.   I: Integer;
  1790. begin
  1791.   if Assigned(FOnObjectMove) then
  1792.   begin
  1793.     R := ObjectRect;
  1794.     I := GetBorderWidth;
  1795.     InflateRect(R, I, I);
  1796.     FOnObjectMove(Self, R);
  1797.   end;
  1798. end;
  1799.  
  1800. function TOleContainer.ObjectPropertiesDialog: Boolean;
  1801. var
  1802.   ObjectProps: TOleUIObjectProps;
  1803.   PropSheet: TPropSheetHeader;
  1804.   GeneralProps: TOleUIGnrlProps;
  1805.   ViewProps: TOleUIViewProps;
  1806.   LinkProps: TOleUILinkProps;
  1807.   DialogCaption: string;
  1808. begin
  1809.   CheckObject;
  1810.   Result := False;
  1811.   FillChar(ObjectProps, SizeOf(ObjectProps), 0);
  1812.   FillChar(PropSheet, SizeOf(PropSheet), 0);
  1813.   FillChar(GeneralProps, SizeOf(GeneralProps), 0);
  1814.   FillChar(ViewProps, SizeOf(ViewProps), 0);
  1815.   FillChar(LinkProps, SizeOf(LinkProps), 0);
  1816.   ObjectProps.cbStruct := SizeOf(ObjectProps);
  1817.   ObjectProps.dwFlags := OPF_DISABLECONVERT;
  1818.   ObjectProps.lpPS := @PropSheet;
  1819.   ObjectProps.lpObjInfo := Self;
  1820.   if Linked then
  1821.   begin
  1822.     ObjectProps.dwFlags := ObjectProps.dwFlags or OPF_OBJECTISLINK;
  1823.     ObjectProps.lpLinkInfo := TOleUILinkInfo.Create(Self);  // acquire olelink
  1824.   end;
  1825.   ObjectProps.lpGP := @GeneralProps;
  1826.   ObjectProps.lpVP := @ViewProps;
  1827.   ObjectProps.lpLP := @LinkProps;
  1828.   PropSheet.dwSize := SizeOf(PropSheet);
  1829.   PropSheet.hWndParent := Application.Handle;
  1830.   PropSheet.hInstance := MainInstance;
  1831.   DialogCaption := Format(SPropDlgCaption, [GetFullNameStr(FOleObject)]);
  1832.   PropSheet.pszCaption := PChar(DialogCaption);
  1833.   GeneralProps.cbStruct := SizeOf(GeneralProps);
  1834.   GeneralProps.lpfnHook := OleDialogHook;
  1835.   ViewProps.cbStruct := SizeOf(ViewProps);
  1836.   ViewProps.dwFlags := VPF_DISABLESCALE;
  1837.   LinkProps.cbStruct := SizeOf(LinkProps);
  1838.   LinkProps.dwFlags := ELF_DISABLECANCELLINK;
  1839.   if OleUIObjectProperties(ObjectProps) = OLEUI_OK then Result := True;
  1840. end;
  1841.  
  1842. procedure TOleContainer.Paint;
  1843. var
  1844.   W, H: Integer;
  1845.   S: TPoint;
  1846.   R, CR: TRect;
  1847.   Flags: Integer;
  1848. begin
  1849.   if FDocObj and FUIActive then Exit;
  1850.   CR := Rect(0,0,Width,Height);
  1851.   if FBorderStyle = bsSingle then
  1852.   begin
  1853.     if NewStyleControls and Ctl3D then
  1854.       Flags := BF_ADJUST or BF_RECT
  1855.     else
  1856.       Flags := BF_ADJUST or BF_RECT or BF_MONO;
  1857.   end
  1858.   else
  1859.     Flags := BF_FLAT;
  1860.  
  1861.   Canvas.Brush.Style := bsSolid;
  1862.   Canvas.Brush.Color := Color;
  1863.   DrawEdge(Canvas.Handle, CR, EDGE_SUNKEN, Flags or BF_MIDDLE);
  1864.   if FOleObject <> nil then
  1865.   begin
  1866.     W := CR.Right - CR.Left;
  1867.     H := CR.Bottom - CR.Top;
  1868.     S := HimetricToPixels(FViewSize);
  1869.     if (FDrawAspect = DVASPECT_CONTENT) and (FSizeMode = smScale) then
  1870.       if W * S.Y > H * S.X then
  1871.       begin
  1872.         S.X := S.X * H div S.Y;
  1873.         S.Y := H;
  1874.       end else
  1875.       begin
  1876.         S.Y := S.Y * W div S.X;
  1877.         S.X := W;
  1878.       end;
  1879.     if (FDrawAspect = DVASPECT_ICON) or (FSizeMode = smCenter) or
  1880.       (FSizeMode = smScale) then
  1881.     begin
  1882.       R.Left := (W - S.X) div 2;
  1883.       R.Top := (H - S.Y) div 2;
  1884.       R.Right := R.Left + S.X;
  1885.       R.Bottom := R.Top + S.Y;
  1886.     end
  1887.     else if FSizeMode = smClip then
  1888.     begin
  1889.       SetRect(R, CR.Left, CR.Top, S.X, S.Y);
  1890.       IntersectClipRect(Canvas.Handle, CR.Left, CR.Top, CR.Right, CR.Bottom);
  1891.     end
  1892.     else
  1893.       SetRect(R, CR.Left, CR.Top, W, H);
  1894.     OleDraw(FOleObject, FDrawAspect, Canvas.Handle, R);
  1895.     if FObjectOpen then ShadeRect(Canvas.Handle, CR);
  1896.   end;
  1897.   if FFocused then Canvas.DrawFocusRect(CR);
  1898. end;
  1899.  
  1900. procedure TOleContainer.Paste;
  1901. var
  1902.   DataObject: IDataObject;
  1903.   Descriptor: PObjectDescriptor;
  1904.   FormatEtc: TFormatEtc;
  1905.   Medium: TStgMedium;
  1906.   CreateInfo: TCreateInfo;
  1907. begin
  1908.   if not CanPaste then Exit;
  1909.   OleCheck(OleGetClipboard(DataObject));
  1910.   try
  1911.     CreateInfo.CreateType := ctFromData;
  1912.     CreateInfo.ShowAsIcon := False;
  1913.     CreateInfo.IconMetaPict := 0;
  1914.     CreateInfo.DataObject := DataObject;
  1915.     FormatEtc.cfFormat := CFObjectDescriptor;
  1916.     FormatEtc.ptd := nil;
  1917.     FormatEtc.dwAspect := DVASPECT_CONTENT;
  1918.     FormatEtc.lIndex := -1;
  1919.     FormatEtc.tymed := TYMED_HGLOBAL;
  1920.     if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
  1921.     begin
  1922.       Descriptor := GlobalLock(Medium.hGlobal);
  1923.       if Descriptor^.dwDrawAspect = DVASPECT_ICON then
  1924.         CreateInfo.ShowAsIcon := True;
  1925.       GlobalUnlock(Medium.hGlobal);
  1926.       ReleaseStgMedium(Medium);
  1927.     end;
  1928.     if CreateInfo.ShowAsIcon then
  1929.     begin
  1930.       FormatEtc.cfFormat := CF_METAFILEPICT;
  1931.       FormatEtc.ptd := nil;
  1932.       FormatEtc.dwAspect := DVASPECT_ICON;
  1933.       FormatEtc.lIndex := -1;
  1934.       FormatEtc.tymed := TYMED_MFPICT;
  1935.       if Succeeded(DataObject.GetData(FormatEtc, Medium)) then
  1936.         CreateInfo.IconMetaPict := Medium.hMetaFilePict;
  1937.     end;
  1938.     CreateObjectFromInfo(CreateInfo);
  1939.   finally
  1940.     DestroyMetaPict(CreateInfo.IconMetaPict);
  1941.   end;
  1942. end;
  1943.  
  1944. function TOleContainer.PasteSpecialDialog: Boolean;
  1945. const
  1946.   PasteFormatCount = 2;
  1947. var
  1948.   Data: TOleUIPasteSpecial;
  1949.   PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry;
  1950.   CreateInfo: TCreateInfo;
  1951. begin
  1952.   Result := False;
  1953.   if not CanPaste then Exit;
  1954.   FillChar(Data, SizeOf(Data), 0);
  1955.   FillChar(PasteFormats, SizeOf(PasteFormats), 0);
  1956.   Data.cbStruct := SizeOf(Data);
  1957.   Data.hWndOwner := Application.Handle;
  1958.   Data.lpfnHook := OleDialogHook;
  1959.   Data.arrPasteEntries := @PasteFormats;
  1960.   Data.cPasteEntries := PasteFormatCount;
  1961.   Data.arrLinkTypes := @CFLinkSource;
  1962.   Data.cLinkTypes := 1;
  1963.   PasteFormats[0].fmtetc.cfFormat := CFEmbeddedObject;
  1964.   PasteFormats[0].fmtetc.dwAspect := DVASPECT_CONTENT;
  1965.   PasteFormats[0].fmtetc.lIndex := -1;
  1966.   PasteFormats[0].fmtetc.tymed := TYMED_ISTORAGE;
  1967.   PasteFormats[0].lpstrFormatName := '%s';
  1968.   PasteFormats[0].lpstrResultText := '%s';
  1969.   PasteFormats[0].dwFlags := OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON;
  1970.   PasteFormats[1].fmtetc.cfFormat := CFLinkSource;
  1971.   PasteFormats[1].fmtetc.dwAspect := DVASPECT_CONTENT;
  1972.   PasteFormats[1].fmtetc.lIndex := -1;
  1973.   PasteFormats[1].fmtetc.tymed := TYMED_ISTREAM;
  1974.   PasteFormats[1].lpstrFormatName := '%s';
  1975.   PasteFormats[1].lpstrResultText := '%s';
  1976.   PasteFormats[1].dwFlags := OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON;
  1977.   try
  1978.     if OleUIPasteSpecial(Data) = OLEUI_OK then
  1979.     begin
  1980.       if Data.fLink then
  1981.         CreateInfo.CreateType := ctLinkFromData else
  1982.         CreateInfo.CreateType := ctFromData;
  1983.       CreateInfo.ShowAsIcon := Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0;
  1984.       CreateInfo.IconMetaPict := Data.hMetaPict;
  1985.       CreateInfo.DataObject := Data.lpSrcDataObj;
  1986.       CreateObjectFromInfo(CreateInfo);
  1987.       Result := True;
  1988.     end;
  1989.   finally
  1990.     DestroyMetaPict(Data.hMetaPict);
  1991.   end;
  1992. end;
  1993.  
  1994. procedure TOleContainer.PopupVerbMenuClick(Sender: TObject);
  1995. begin
  1996.   DoVerb((Sender as TMenuItem).Tag);
  1997. end;
  1998.  
  1999. function TOleContainer.QueryInterface(const iid: TIID; out obj): HResult;
  2000. begin
  2001.   Pointer(obj) := nil;
  2002.   Result := E_NOINTERFACE;
  2003.   if IsEqualIID(iid, IOleDocumentSite) and
  2004.     (not FAllowActiveDoc or (csDesigning in ComponentState)) then Exit;
  2005.   if GetInterface(iid, obj) then Result := S_OK;
  2006. end;
  2007.  
  2008. function TOleContainer._Release: Integer;
  2009. begin
  2010.   Dec(FRefCount);
  2011.   Result := FRefCount;
  2012. end;
  2013.  
  2014. procedure TOleContainer.Run;
  2015. begin
  2016.   CheckObject;
  2017.   OleCheck(OleRun(FOleObject));
  2018. end;
  2019.  
  2020. function TOleContainer.SaveObject: HResult;
  2021. var
  2022.   PersistStorage: IPersistStorage;
  2023. begin
  2024.   Result := S_OK;
  2025.   if FOleObject = nil then Exit;
  2026.   PersistStorage := FOleObject as IPersistStorage;
  2027.   OleCheck(OleSave(PersistStorage, FStorage, True));
  2028.   PersistStorage.SaveCompleted(nil);
  2029.   PersistStorage := nil;
  2030.   OleCheck(FStorage.Commit(STGC_DEFAULT));
  2031.   FModSinceSave := False;
  2032. end;
  2033.  
  2034. procedure TOleContainer.SaveAsDocument(const FileName: string);
  2035. var
  2036.   TempStorage: IStorage;
  2037.   PersistStorage: IPersistStorage;
  2038. begin
  2039.   CheckObject;
  2040.   if FModSinceSave then SaveObject;
  2041.   FOleObject.QueryInterface(IPersistStorage, PersistStorage);
  2042.   if PersistStorage <> nil then
  2043.   begin
  2044.     OleCheck(StgCreateDocFile(PWideChar(WideString(Filename)), STGM_READWRITE
  2045.       or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, TempStorage));
  2046.     OleCheck(OleSave(PersistStorage, TempStorage, False));
  2047.     PersistStorage.SaveCompleted(nil);
  2048.   end;
  2049. end;
  2050.  
  2051. procedure TOleContainer.SaveToFile(const FileName: string);
  2052. var
  2053.   Stream: TStream;
  2054. begin
  2055.   Stream := TFileStream.Create(FileName, fmCreate);
  2056.   try
  2057.     SaveToStream(Stream);
  2058.   finally
  2059.     Stream.Free;
  2060.   end;
  2061. end;
  2062.  
  2063. procedure TOleContainer.SaveToStream(Stream: TStream);
  2064. var
  2065.   TempLockBytes: ILockBytes;
  2066.   TempStorage: IStorage;
  2067.   DataHandle: HGlobal;
  2068.   Buffer: Pointer;
  2069.   Header: TStreamHeader;
  2070.   R: TRect;
  2071. begin
  2072.   CheckObject;
  2073.   if FModSinceSave then SaveObject;
  2074.   if FCopyOnSave then
  2075.   begin
  2076.     OleCheck(CreateILockBytesOnHGlobal(0, True, TempLockBytes));
  2077.     OleCheck(StgCreateDocfileOnILockBytes(TempLockBytes, STGM_READWRITE
  2078.       or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, TempStorage));
  2079.     OleCheck(FStorage.CopyTo(0, nil, nil, TempStorage));
  2080.     OleCheck(TempStorage.Commit(STGC_DEFAULT));
  2081.     OleCheck(GetHGlobalFromILockBytes(TempLockBytes, DataHandle));
  2082.   end else
  2083.     OleCheck(GetHGlobalFromILockBytes(FLockBytes, DataHandle));
  2084.   if FOldStreamFormat then
  2085.   begin
  2086.     R := BoundsRect;
  2087.     Header.PartRect.Left := R.Left;
  2088.     Header.PartRect.Top := R.Top;
  2089.     Header.PartRect.Right := R.Right;
  2090.     Header.PartRect.Bottom := R.Bottom;
  2091.   end else
  2092.   begin
  2093.     Header.Signature := StreamSignature;
  2094.     Header.DrawAspect := FDrawAspect;
  2095.   end;
  2096.   Header.DataSize := GlobalSize(DataHandle);
  2097.   Stream.WriteBuffer(Header, SizeOf(Header));
  2098.   Buffer := GlobalLock(DataHandle);
  2099.   try
  2100.     Stream.WriteBuffer(Buffer^, Header.DataSize);
  2101.   finally
  2102.     GlobalUnlock(DataHandle);
  2103.   end;
  2104. end;
  2105.  
  2106. procedure TOleContainer.SetBorderStyle(Value: TBorderStyle);
  2107. begin
  2108.   if FBorderStyle <> Value then
  2109.   begin
  2110.     FBorderStyle := Value;
  2111.     AdjustBounds;
  2112.     Invalidate;
  2113.   end;
  2114. end;
  2115.  
  2116. procedure TOleContainer.SetDrawAspect(Iconic: Boolean;
  2117.   IconMetaPict: HGlobal);
  2118. var
  2119.   OleCache: IOleCache;
  2120.   EnumStatData: IEnumStatData;
  2121.   OldAspect, AdviseFlags, Connection: Longint;
  2122.   TempMetaPict: HGlobal;
  2123.   FormatEtc: TFormatEtc;
  2124.   Medium: TStgMedium;
  2125.   ClassID: TCLSID;
  2126.   StatData: TStatData;
  2127. begin
  2128.   OldAspect := FDrawAspect;
  2129.   if Iconic then
  2130.   begin
  2131.     FDrawAspect := DVASPECT_ICON;
  2132.     AdviseFlags := ADVF_NODATA;
  2133.   end else
  2134.   begin
  2135.     FDrawAspect := DVASPECT_CONTENT;
  2136.     AdviseFlags := ADVF_PRIMEFIRST;
  2137.   end;
  2138.   if (FDrawAspect <> OldAspect) or (FDrawAspect = DVASPECT_ICON) then
  2139.   begin
  2140.     OleCache := FOleObject as IOleCache;
  2141.     if FDrawAspect <> OldAspect then
  2142.     begin
  2143.       OleCheck(OleCache.EnumCache(EnumStatData));
  2144.       if EnumStatData <> nil then
  2145.         while EnumStatData.Next(1, StatData, nil) = 0 do
  2146.           if StatData.formatetc.dwAspect = OldAspect then
  2147.             OleCache.Uncache(StatData.dwConnection);
  2148.       FillChar(FormatEtc, SizeOf(FormatEtc), 0);
  2149.       FormatEtc.dwAspect := FDrawAspect;
  2150.       FormatEtc.lIndex := -1;
  2151.       OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
  2152.       SetViewAdviseSink(True);
  2153.     end;
  2154.     if FDrawAspect = DVASPECT_ICON then
  2155.     begin
  2156.       TempMetaPict := 0;
  2157.       if IconMetaPict = 0 then
  2158.       begin
  2159.         OleCheck(FOleObject.GetUserClassID(ClassID));
  2160.         TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
  2161.         IconMetaPict := TempMetaPict;
  2162.       end;
  2163.       try
  2164.         FormatEtc.cfFormat := CF_METAFILEPICT;
  2165.         FormatEtc.ptd := nil;
  2166.         FormatEtc.dwAspect := DVASPECT_ICON;
  2167.         FormatEtc.lIndex := -1;
  2168.         FormatEtc.tymed := TYMED_MFPICT;
  2169.         Medium.tymed := TYMED_MFPICT;
  2170.         Medium.hMetaFilePict := IconMetaPict;
  2171.         Medium.unkForRelease := nil;
  2172.         OleCheck(OleCache.SetData(FormatEtc, Medium, False));
  2173.       finally
  2174.         DestroyMetaPict(TempMetaPict);
  2175.       end;
  2176.     end;
  2177.     if FDrawAspect = DVASPECT_CONTENT then UpdateObject;
  2178.     UpdateView;
  2179.   end;
  2180. end;
  2181.  
  2182. procedure TOleContainer.SetFocused(Value: Boolean);
  2183. var
  2184.   R: TRect;
  2185. begin
  2186.   if FFocused <> Value then
  2187.   begin
  2188.     FFocused := Value;
  2189.     if GetUpdateRect(Handle, PRect(nil)^, False) then
  2190.       Invalidate
  2191.     else
  2192.     begin
  2193.       R := ClientRect;
  2194.       InflateRect(R, -GetBorderWidth, -GetBorderWidth);
  2195.       Canvas.DrawFocusRect(R);
  2196.     end;
  2197.   end;
  2198. end;
  2199.  
  2200. procedure TOleContainer.SetIconic(Value: Boolean);
  2201. begin
  2202.   if GetIconic <> Value then
  2203.   begin
  2204.     CheckObject;
  2205.     SetDrawAspect(Value, 0);
  2206.   end;
  2207. end;
  2208.  
  2209. procedure TOleContainer.SetSizeMode(Value: TSizeMode);
  2210. begin
  2211.   if FSizeMode <> Value then
  2212.   begin
  2213.     FSizeMode := Value;
  2214.     AdjustBounds;
  2215.     Invalidate;
  2216.   end;
  2217. end;
  2218.  
  2219. procedure TOleContainer.SetUIActive(Active: Boolean);
  2220. var
  2221.   Form: TCustomForm;
  2222. begin
  2223.   try
  2224.     FUIActive := Active;
  2225.     Form := GetParentForm(Self);
  2226.     if Form <> nil then
  2227.       if Active then
  2228.       begin
  2229.         if (Form.ActiveOleControl <> nil) and
  2230.           (Form.ActiveOleControl <> Self) then
  2231.           Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  2232.         Form.ActiveOleControl := Self;
  2233.         SetFocus;
  2234.         if Assigned(FOnActivate) then FOnActivate(Self);
  2235.       end else
  2236.       begin
  2237.         if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil;
  2238.         if Form.ActiveControl = Self then Windows.SetFocus(Handle);
  2239.         DestroyAccelTable;
  2240.         if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  2241.       end;
  2242.   except
  2243.     Application.HandleException(Self);
  2244.   end;
  2245. end;
  2246.  
  2247. procedure TOleContainer.SetViewAdviseSink(Enable: Boolean);
  2248. var
  2249.   ViewObject: IViewObject;
  2250.   AdviseSink: IAdviseSink;
  2251. begin
  2252.   if FOleObject.QueryInterface(IViewObject, ViewObject) <> 0 then Exit;
  2253.   if Enable then AdviseSink := Self else AdviseSink := nil;
  2254.   ViewObject.SetAdvise(FDrawAspect, 0, AdviseSink);
  2255. end;
  2256.  
  2257. procedure TOleContainer.UpdateObject;
  2258. begin
  2259.   if FOleObject <> nil then
  2260.   begin
  2261.     OleCheck(FOleObject.Update);
  2262.     Changed;
  2263.   end;
  2264. end;
  2265.  
  2266. procedure TOleContainer.UpdateObjectRect;
  2267. var
  2268.   P: TPoint;
  2269.   R: TRect;
  2270. begin
  2271.   if FDocObj and (FDocView <> nil) then
  2272.     FDocView.SetRect(ClientRect)
  2273.   else
  2274.   begin
  2275.     P := Parent.ScreenToClient(ClientOrigin);
  2276.     R := Rect(P.X, P.Y, P.X + ClientWidth, P.Y + ClientHeight);
  2277.     if FOleInPlaceObject <> nil then
  2278.       FOleInPlaceObject.SetObjectRects(R, Rect(-16384, -16384, 16383, 16383));
  2279.   end;
  2280. end;
  2281.  
  2282. procedure TOleContainer.UpdateVerbs;
  2283. var
  2284.   EnumOleVerb: IEnumOleVerb;
  2285.   OleVerb: TOleVerb;
  2286.   VerbInfo: TVerbInfo;
  2287. begin
  2288.   CheckObject;
  2289.   DestroyVerbs;
  2290.   FObjectVerbs := TStringList.Create;
  2291.   if FOleObject.EnumVerbs(EnumOleVerb) = 0 then
  2292.   begin
  2293.     while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and
  2294.       (OleVerb.lVerb >= 0) and
  2295.       (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do
  2296.     begin
  2297.       VerbInfo.Verb := OleVerb.lVerb;
  2298.       VerbInfo.Flags := OleVerb.fuFlags;
  2299.       FObjectVerbs.AddObject(OleVerb.lpszVerbName, TObject(VerbInfo));
  2300.     end;
  2301.   end;
  2302. end;
  2303.  
  2304. procedure TOleContainer.UpdateView;
  2305. var
  2306.   ViewObject2: IViewObject2;
  2307. begin
  2308.   if Succeeded(FOleObject.QueryInterface(IViewObject2, ViewObject2)) then
  2309.   begin
  2310.     ViewObject2.GetExtent(FDrawAspect, -1, nil, FViewSize);
  2311.     AdjustBounds;
  2312.   end;
  2313.   Invalidate;
  2314.   Changed;
  2315. end;
  2316.  
  2317. procedure TOleContainer.CMCtl3DChanged(var Message: TMessage);
  2318. begin
  2319.   if NewStyleControls and (FBorderStyle = bsSingle) then
  2320.   begin
  2321.     AdjustBounds;
  2322.     Invalidate;
  2323.   end;
  2324.   inherited;
  2325. end;
  2326.  
  2327. procedure TOleContainer.CMDocWindowActivate(var Message: TMessage);
  2328. begin
  2329.   if Assigned(FDocForm) and IsFormMDIChild(FDocForm.Form) then
  2330.   begin
  2331.     FOleInPlaceActiveObject.OnDocWindowActivate(LongBool(Message.WParam));
  2332.     if Message.WParam = 0 then
  2333.     begin
  2334.       FFrameForm.SetMenu(0, 0, 0);
  2335.       FFrameForm.ClearBorderSpace;
  2336.     end;
  2337.   end;
  2338. end;
  2339.  
  2340. procedure TOleContainer.CMUIDeactivate(var Message: TMessage);
  2341. begin
  2342.   if (GetParentForm(Self).ActiveOleControl = Self) and (FOleInPlaceObject <> nil) then
  2343.     FOleInPlaceObject.UIDeactivate;
  2344. end;
  2345.  
  2346. procedure TOleContainer.WMKillFocus(var Message: TWMSetFocus);
  2347. begin
  2348.   inherited;
  2349.   SetFocused(False);
  2350. end;
  2351.  
  2352. procedure TOleContainer.WMSetFocus(var Message: TWMSetFocus);
  2353. var
  2354.   Window: HWnd;
  2355. begin
  2356.   inherited;
  2357.   if FUIActive and (FOleInPlaceObject.GetWindow(Window) = 0) then
  2358.     Windows.SetFocus(Window)
  2359.   else
  2360.     SetFocused(True);
  2361. end;
  2362.  
  2363. procedure TOleContainer.WMSize(var Message: TWMSize);
  2364. begin
  2365.   inherited;
  2366.   if not (csLoading in ComponentState) and Assigned(FOnResize) then
  2367.     FOnResize(Self);
  2368.   if not FDocObj or not FUIActive then Invalidate;
  2369. end;
  2370.  
  2371. procedure TOleContainer.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  2372. var
  2373.   R: TRect;
  2374. begin
  2375.   R := BoundsRect;
  2376.   inherited;
  2377.   if FUIActive and not EqualRect(BoundsRect, R) then UpdateObjectRect;
  2378. end;
  2379.  
  2380. { TOleForm.IOleForm }
  2381.  
  2382. procedure TOleForm.OnDestroy;
  2383. var
  2384.   I: Integer;
  2385. begin
  2386.   for I := FContainers.Count - 1 downto 0 do
  2387.     TOleContainer(FContainers[I]).DestroyObject;
  2388. end;
  2389.  
  2390. procedure TOleForm.OnResize;
  2391. var
  2392.   BorderRect: TRect;
  2393. begin
  2394.   if (FActiveObject <> nil) and (FForm.WindowState <> wsMinimized) and
  2395.     ((FForm.ClientWidth <> FSaveWidth) or
  2396.     (FForm.ClientHeight <> FSaveHeight)) then
  2397.   begin
  2398.     GetBorder(BorderRect);
  2399.     FActiveObject.ResizeBorder(BorderRect, Self, True);
  2400.     FSaveWidth := FForm.ClientWidth;
  2401.     FSaveHeight := FForm.ClientHeight;
  2402.   end;
  2403. end;
  2404.  
  2405. { TOleForm.IOleInPlaceFrame }
  2406.  
  2407. function TOleForm.GetWindow(out wnd: HWnd): HResult;
  2408. begin
  2409.   wnd := FForm.Handle;
  2410.   Result := S_OK;
  2411. end;
  2412.  
  2413. function TOleForm.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  2414. begin
  2415.   Result := S_OK;
  2416. end;
  2417.  
  2418. function TOleForm.GetBorder(out BorderRect: TRect): HResult;
  2419. var
  2420.   I: Integer;
  2421.   Control: TControl;
  2422. begin
  2423.   Result := S_OK;
  2424.   BorderRect := FForm.ClientRect;
  2425.   for I := 0 to FForm.ControlCount - 1 do
  2426.   begin
  2427.     Control := FForm.Controls[I];
  2428.     if Control.Visible and not IsSpacer(Control) and
  2429.       not IsToolControl(Control) then
  2430.       case Control.Align of
  2431.         alLeft: Inc(BorderRect.Left, Control.Width);
  2432.         alRight: Dec(BorderRect.Right, Control.Width);
  2433.         alTop: Inc(BorderRect.Top, Control.Height);
  2434.         alBottom: Dec(BorderRect.Bottom, Control.Height);
  2435.       end;
  2436.   end;
  2437. end;
  2438.  
  2439. function TOleForm.RequestBorderSpace(const borderwidths: TRect): HResult;
  2440. var
  2441.   I: Integer;
  2442. begin
  2443.   Result := S_OK;
  2444.   if (FForm is TForm) and (TForm(FForm).FormStyle = fsMDIForm) then Exit;
  2445.   for I := 0 to FForm.ControlCount - 1 do
  2446.     with FForm.Controls[I] do
  2447.       if Visible and (Align = alClient) then Exit;
  2448.   Result := INPLACE_E_NOTOOLSPACE;
  2449. end;
  2450.  
  2451. function TOleForm.SetBorderSpace(pborderwidths: PRect): HResult;
  2452. type
  2453.   PRectArray = ^TRectArray;
  2454.   TRectArray = array[0..3] of Integer;
  2455. const
  2456.   Alignments: array[0..3] of TAlign = (alLeft, alTop, alRight, alBottom);
  2457. var
  2458.   I, J, Size: Integer;
  2459.   Control, Spacer: TControl;
  2460. begin
  2461.   Result := S_OK;
  2462.   if (pborderwidths = nil) then Exit;
  2463.   Result := RequestBorderSpace(pBorderWidths^);
  2464.   if Result <> S_OK then Exit;
  2465.   FForm.DisableAlign;
  2466.   for I := 0 to FForm.ControlCount - 1 do
  2467.   begin
  2468.     Control := FForm.Controls[I];
  2469.     if IsToolControl(Control) then
  2470.     begin
  2471.       Control.Visible := False;
  2472.       FHiddenControls.Add(Control);
  2473.     end;
  2474.   end;
  2475.   for I := 0 to 3 do
  2476.   begin
  2477.     Size := PRectArray(pBorderWidths)^[I];
  2478.     if Size > 0 then
  2479.     begin
  2480.       Spacer := FSpacers[I];
  2481.       if Spacer = nil then
  2482.       begin
  2483.         Spacer := TControl.Create(FForm);
  2484.         if I < 2 then J := 10000 else J := -10000;
  2485.         if Odd(I) then Spacer.Top := J else Spacer.Left := J;
  2486.         Spacer.Align := Alignments[I];
  2487.         Spacer.Parent := FForm;
  2488.         FSpacers[I] := Spacer;
  2489.       end;
  2490.       if Odd(I) then Spacer.Height := Size else Spacer.Width := Size;
  2491.     end;
  2492.   end;
  2493.   FForm.EnableAlign;
  2494.   Result := S_OK;
  2495. end;
  2496.  
  2497. function TOleForm.SetActiveObject(const ActiveObject: IOleInPlaceActiveObject;
  2498.   pszObjName: POleStr): HResult;
  2499. var
  2500.   Window, ParentWindow: HWnd;
  2501. begin
  2502.   Result := S_OK;
  2503.   FActiveObject := ActiveObject;
  2504.   if FActiveObject = nil then Exit;
  2505.   if FActiveObject.GetWindow(Window) = 0 then
  2506.     while True do
  2507.     begin
  2508.       ParentWindow := GetParent(Window);
  2509.       if ParentWindow = 0 then Break;
  2510.       if FindControl(ParentWindow) <> nil then
  2511.       begin
  2512.         SetWindowPos(Window, HWND_TOP, 0, 0, 0, 0,
  2513.           SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  2514.         Break;
  2515.       end;
  2516.       Window := ParentWindow;
  2517.     end;
  2518.   FSaveWidth := FForm.ClientWidth;
  2519.   FSaveHeight := FForm.ClientHeight;
  2520. end;
  2521.  
  2522. function TOleForm.InsertMenus(hmenuShared: HMenu;
  2523.   var menuWidths: TOleMenuGroupWidths): HResult;
  2524. var
  2525.   Menu: TMainMenu;
  2526. begin
  2527.   Menu := FForm.Menu;
  2528.   if Menu <> nil then
  2529.     Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);
  2530.   Result := S_OK;
  2531. end;
  2532.  
  2533. function TOleForm.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  2534.   hwndActiveObject: HWnd): HResult;
  2535. var
  2536.   Menu: TMainMenu;
  2537. begin
  2538.   Menu := FForm.Menu;
  2539.   Result := S_OK;
  2540.   if Menu <> nil then
  2541.   begin
  2542.     Menu.SetOle2MenuHandle(hmenuShared);
  2543.     Result := OleSetMenuDescriptor(holemenu, Menu.WindowHandle,
  2544.       hwndActiveObject, nil, nil);
  2545.   end;
  2546. end;
  2547.  
  2548. function TOleForm.RemoveMenus(hmenuShared: HMenu): HResult;
  2549. begin
  2550.   while GetMenuItemCount(hmenuShared) > 0 do
  2551.     RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
  2552.   Result := S_OK;
  2553. end;
  2554.  
  2555. function TOleForm.SetStatusText(pszStatusText: POleStr): HResult;
  2556. begin
  2557.   FForm.Hint := pszStatusText;
  2558. //  Application.Hint := pszStatusText;  // goes away too soon
  2559.   Result := S_OK;
  2560. end;
  2561.  
  2562. function TOleForm.EnableModeless(fEnable: BOOL): HResult;
  2563. begin
  2564.   Result := S_OK;
  2565. end;
  2566.  
  2567. function TOleForm.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
  2568. var
  2569.   Menu: TMainMenu;
  2570. begin
  2571.   Menu := FForm.Menu;
  2572.   if (Menu <> nil) and Menu.DispatchCommand(wID) then
  2573.     Result := S_OK else
  2574.     Result := S_FALSE;
  2575. end;
  2576.  
  2577. { TOleForm }
  2578.  
  2579. constructor TOleForm.Create(Form: TCustomForm);
  2580. begin
  2581.   inherited Create;
  2582.   FForm := Form;
  2583.   FContainers := TList.Create;
  2584.   FHiddenControls := TList.Create;
  2585.   FForm.OleFormObject := Self;
  2586. end;
  2587.  
  2588. destructor TOleForm.Destroy;
  2589. begin
  2590.   if FForm <> nil then FForm.OleFormObject := nil;
  2591.   FHiddenControls.Free;
  2592.   FContainers.Free;
  2593.   inherited Destroy;
  2594. end;
  2595.  
  2596. procedure TOleForm.ClearBorderSpace;
  2597. var
  2598.   I: Integer;
  2599. begin
  2600.   FForm.DisableAlign;
  2601.   for I := 0 to 3 do
  2602.   begin
  2603.     FSpacers[I].Free;
  2604.     FSpacers[I] := nil;
  2605.   end;
  2606.   for I := 0 to FHiddenControls.Count - 1 do
  2607.     TControl(FHiddenControls[I]).Visible := True;
  2608.   FHiddenControls.Clear;
  2609.   FForm.EnableAlign;
  2610. end;
  2611.  
  2612. function TOleForm.IsSpacer(Control: TControl): Boolean;
  2613. var
  2614.   I: Integer;
  2615. begin
  2616.   for I := 0 to 3 do
  2617.     if Control = FSpacers[I] then
  2618.     begin
  2619.       Result := True;
  2620.       Exit;
  2621.     end;
  2622.   Result := False;
  2623. end;
  2624.  
  2625. function TOleForm.IsToolControl(Control: TControl): Boolean;
  2626. begin
  2627.   Result := Control.Visible and
  2628.     (Control.Align in [alTop, alBottom, alLeft, alRight]) and
  2629.     (Control.Perform(CM_ISTOOLCONTROL, 0, 0) <> 0);
  2630. end;
  2631.  
  2632. procedure TOleForm.AddContainer(Instance: TOleContainer);
  2633. begin
  2634.   FContainers.Add(Instance);
  2635. end;
  2636.  
  2637. procedure TOleForm.RemoveContainer(Instance: TOleContainer);
  2638. begin
  2639.   FContainers.Remove(Instance);
  2640. end;
  2641.  
  2642. function TOleForm.Form: TCustomForm;
  2643. begin
  2644.   Result := FForm;
  2645. end;
  2646.  
  2647. { Initialization }
  2648.  
  2649. procedure Initialize;
  2650. var
  2651.   DC: HDC;
  2652. begin
  2653.   DC := GetDC(0);
  2654.   PixPerInch.X := GetDeviceCaps(DC, LOGPIXELSX);
  2655.   PixPerInch.Y := GetDeviceCaps(DC, LOGPIXELSY);
  2656.   ReleaseDC(0, DC);
  2657.   CFObjectDescriptor := RegisterClipboardFormat('Object Descriptor');
  2658.   CFEmbeddedObject := RegisterClipboardFormat('Embedded Object');
  2659.   CFLinkSource := RegisterClipboardFormat('Link Source');
  2660.   DataFormats[0].cfFormat := CFEmbeddedObject;
  2661.   DataFormats[0].dwAspect := DVASPECT_CONTENT;
  2662.   DataFormats[0].lIndex := -1;
  2663.   DataFormats[0].tymed := TYMED_ISTORAGE;
  2664.   DataFormats[1].cfFormat := CFObjectDescriptor;
  2665.   DataFormats[1].dwAspect := DVASPECT_CONTENT;
  2666.   DataFormats[1].lIndex := -1;
  2667.   DataFormats[1].tymed := TYMED_HGLOBAL;
  2668. end;
  2669.  
  2670. initialization
  2671.   OleInitialize(nil);
  2672.   Initialize;
  2673. finalization
  2674.   OleUninitialize;
  2675. end.
  2676.