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