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