home *** CD-ROM | disk | FTP | other *** search
/ Chip 1997 April / Chip_1997-04_cd.bin / prezent / cb / data.z / OLECTNRS.PAS < prev    next >
Pascal/Delphi Source File  |  1997-01-16  |  83KB  |  2,956 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) + 
  1010.     MultiByteToWideChar(0, 0, PChar(UserTypeName), 
  1011.       Length(UserTypeName), nil, 0) +
  1012.     MultiByteToWideChar(0, 0, PChar(SourceOfCopy), 
  1013.       Length(SourceOfCopy), nil, 0) + 4;
  1014.   Result := GlobalAlloc(GMEM_MOVEABLE, DescSize);
  1015.   if Result <> 0 then
  1016.   begin
  1017.     Descriptor := GlobalLock(Result);
  1018.     FillChar(Descriptor^, 0, DescSize);
  1019.     with Descriptor^ do
  1020.     begin
  1021.       cbSize := DescSize;
  1022.       FOleObject.GetUserClassID(clsid);
  1023.       dwDrawAspect := DVASPECT_CONTENT;
  1024.       FOleObject.GetMiscStatus(DVASPECT_CONTENT, dwStatus);
  1025.       dwFullUserTypeName := SizeOf(TObjectDescriptor);
  1026.       StringToWideChar(UserTypeName, PWideChar(Integer(Descriptor) +
  1027.         dwFullUserTypeName), 256);
  1028.       dwSrcOfCopy := SizeOf(TObjectDescriptor) + 
  1029.         MultiByteToWideChar(0, 0, PChar(UserTypeName), 
  1030.           Length(UserTypeName), nil, 0) + 2;
  1031.       StringToWideChar(SourceOfCopy, PWideChar(Integer(Descriptor) +
  1032.         dwSrcOfCopy), 256);
  1033.     end;
  1034.     GlobalUnlock(Result);
  1035.   end;
  1036. end;
  1037.  
  1038. function TDataObject.QueryInterface(const iid: TIID; var obj): HResult;
  1039. begin
  1040.   if IsEqualIID(iid, IID_IUnknown) or IsEqualIID(iid, IID_IDataObject) then
  1041.   begin
  1042.     Pointer(obj) := Self;
  1043.     AddRef;
  1044.     Result := S_OK;
  1045.   end else
  1046.   begin
  1047.     Pointer(obj) := nil;
  1048.     Result := E_NOINTERFACE;
  1049.   end;
  1050. end;
  1051.  
  1052. function TDataObject.AddRef: Longint;
  1053. begin
  1054.   Inc(FRefCount);
  1055.   Result := FRefCount;
  1056. end;
  1057.  
  1058. function TDataObject.Release: Longint;
  1059. begin
  1060.   Dec(FRefCount);
  1061.   Result := FRefCount;
  1062.   if FRefCount = 0 then Free;
  1063. end;
  1064.  
  1065. function TDataObject.GetData(var formatetcIn: TFormatEtc;
  1066.   var medium: TStgMedium): HResult;
  1067. var
  1068.   Descriptor: HGlobal;
  1069. begin
  1070.   Result := DV_E_FORMATETC;
  1071.   medium.tymed := 0;
  1072.   medium.hGlobal := 0;
  1073.   medium.unkForRelease := nil;
  1074.   with formatetcIn do
  1075.   begin
  1076.     if (cfFormat = CFObjectDescriptor) and (dwAspect = DVASPECT_CONTENT) and
  1077.       (tymed = TYMED_HGLOBAL) then
  1078.     begin
  1079.       Descriptor := GetObjectDescriptor;
  1080.       if Descriptor <> 0 then
  1081.       begin
  1082.         medium.tymed := TYMED_HGLOBAL;
  1083.         medium.hGlobal := Descriptor;
  1084.         Result := S_OK;
  1085.       end;
  1086.     end;
  1087.   end;
  1088. end;
  1089.  
  1090. function TDataObject.GetDataHere(var formatetc: TFormatEtc;
  1091.   var medium: TStgMedium): HResult;
  1092. var
  1093.   PersistStorage: IPersistStorage;
  1094. begin
  1095.   Result := DV_E_FORMATETC;
  1096.   with formatetc do
  1097.     if (cfFormat = CFEmbeddedObject) and (dwAspect = DVASPECT_CONTENT) and
  1098.       (tymed = TYMED_ISTORAGE) then
  1099.     begin
  1100.       medium.unkForRelease := nil;
  1101.       FOleObject.QueryInterface(IID_IPersistStorage, PersistStorage);
  1102.       if PersistStorage <> nil then
  1103.       begin
  1104.         Result := OleSave(PersistStorage, medium.stg, False);
  1105.         PersistStorage.SaveCompleted(nil);
  1106.         PersistStorage.Release;
  1107.       end;
  1108.     end;
  1109. end;
  1110.  
  1111. function TDataObject.QueryGetData(var formatetc: TFormatEtc): HResult;
  1112. begin
  1113.   Result := DV_E_FORMATETC;
  1114.   with formatetc do
  1115.     if dwAspect = DVASPECT_CONTENT then
  1116.       if (cfFormat = CFEmbeddedObject) and (tymed = TYMED_ISTORAGE) or
  1117.         (cfFormat = CFObjectDescriptor) and (tymed = TYMED_HGLOBAL) then
  1118.         Result := S_OK;
  1119. end;
  1120.  
  1121. function TDataObject.GetCanonicalFormatEtc(var formatetc: TFormatEtc;
  1122.   var formatetcOut: TFormatEtc): HResult;
  1123. begin
  1124.   formatetcOut.ptd := nil;
  1125.   Result := E_NOTIMPL;
  1126. end;
  1127.  
  1128. function TDataObject.SetData(var formatetc: TFormatEtc; var medium: TStgMedium;
  1129.   fRelease: BOOL): HResult;
  1130. begin
  1131.   Result := E_NOTIMPL;
  1132. end;
  1133.  
  1134. function TDataObject.EnumFormatEtc(dwDirection: Longint; var enumFormatEtc:
  1135.   IEnumFormatEtc): HResult;
  1136. begin
  1137.   if dwDirection = DATADIR_GET then
  1138.   begin
  1139.     enumFormatEtc := TEnumFormatEtc.Create(@DataFormats, DataFormatCount, 0);
  1140.     Result := S_OK;
  1141.   end else
  1142.   begin
  1143.     enumFormatEtc := nil;
  1144.     Result := E_NOTIMPL;
  1145.   end;
  1146. end;
  1147.  
  1148. function TDataObject.DAdvise(var formatetc: TFormatEtc; advf: Longint;
  1149.   advSink: IAdviseSink; var dwConnection: Longint): HResult;
  1150. begin
  1151.   Result := OLE_E_ADVISENOTSUPPORTED;
  1152. end;
  1153.  
  1154. function TDataObject.DUnadvise(dwConnection: Longint): HResult;
  1155. begin
  1156.   Result := OLE_E_ADVISENOTSUPPORTED;
  1157. end;
  1158.  
  1159. function TDataObject.EnumDAdvise(var enumAdvise: IEnumStatData): HResult;
  1160. begin
  1161.   Result := OLE_E_ADVISENOTSUPPORTED;
  1162. end;
  1163.  
  1164. { TOleClientSite }
  1165.  
  1166. constructor TOleClientSite.Create(Container: TOleContainer);
  1167. begin
  1168.   FContainer := Container;
  1169. end;
  1170.  
  1171. function TOleClientSite.QueryInterface(const iid: TIID; var obj): HResult;
  1172. begin
  1173.   Result := FContainer.QueryInterface(iid, obj);
  1174. end;
  1175.  
  1176. function TOleClientSite.AddRef: Longint;
  1177. begin
  1178.   Result := FContainer.AddRef;
  1179. end;
  1180.  
  1181. function TOleClientSite.Release: Longint;
  1182. begin
  1183.   Result := FContainer.Release;
  1184. end;
  1185.  
  1186. function TOleClientSite.SaveObject: HResult;
  1187. begin
  1188.   FContainer.SaveObject;
  1189.   Result := S_OK;
  1190. end;
  1191.  
  1192. function TOleClientSite.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  1193.   var mk: IMoniker): HResult;
  1194. begin
  1195.   mk := nil;
  1196.   Result := E_NOTIMPL;
  1197. end;
  1198.  
  1199. function TOleClientSite.GetContainer(var container: IOleContainer): HResult;
  1200. begin
  1201.   container := nil;
  1202.   Result := E_NOTIMPL;
  1203. end;
  1204.  
  1205. function TOleClientSite.ShowObject: HResult;
  1206. begin
  1207.   Result := S_OK;
  1208. end;
  1209.  
  1210. function TOleClientSite.OnShowWindow(fShow: BOOL): HResult;
  1211. begin
  1212.   FContainer.ObjectShowWindow(fShow);
  1213.   Result := S_OK;
  1214. end;
  1215.  
  1216. function TOleClientSite.RequestNewObjectLayout: HResult;
  1217. begin
  1218.   Result := E_NOTIMPL;
  1219. end;
  1220.  
  1221. { TOleInPlaceSite }
  1222.  
  1223. constructor TOleInPlaceSite.Create(Container: TOleContainer);
  1224. begin
  1225.   FContainer := Container;
  1226. end;
  1227.  
  1228. function TOleInPlaceSite.QueryInterface(const iid: TIID; var obj): HResult;
  1229. begin
  1230.   Result := FContainer.QueryInterface(iid, obj);
  1231. end;
  1232.  
  1233. function TOleInPlaceSite.AddRef: Longint;
  1234. begin
  1235.   Result := FContainer.AddRef;
  1236. end;
  1237.  
  1238. function TOleInPlaceSite.Release: Longint;
  1239. begin
  1240.   Result := FContainer.Release;
  1241. end;
  1242.  
  1243. function TOleInPlaceSite.GetWindow(var wnd: HWnd): HResult;
  1244. begin
  1245.   wnd := FContainer.Parent.Handle;
  1246.   Result := S_OK;
  1247. end;
  1248.  
  1249. function TOleInPlaceSite.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  1250. begin
  1251.   Result := S_OK;
  1252. end;
  1253.  
  1254. function TOleInPlaceSite.CanInPlaceActivate: HResult;
  1255. begin
  1256.   with FContainer do
  1257.     if not (csDesigning in ComponentState) and Visible and
  1258.       AllowInPlace and not Iconic then
  1259.       Result := S_OK else
  1260.       Result := S_FALSE;
  1261. end;
  1262.  
  1263. function TOleInPlaceSite.OnInPlaceActivate: HResult;
  1264. begin
  1265.   with FContainer do
  1266.   begin
  1267.     FOleObject.QueryInterface(IID_IOleInPlaceObject, FOleInPlaceObject);
  1268.     FOleObject.QueryInterface(IID_IOleInPlaceActiveObject, FOleInPlaceActiveObject);
  1269.   end;
  1270.   Result := S_OK;
  1271. end;
  1272.  
  1273. function TOleInPlaceSite.OnUIActivate: HResult;
  1274. begin
  1275.   FContainer.SetUIActive(True);
  1276.   Result := S_OK;
  1277. end;
  1278.  
  1279. function TOleInPlaceSite.GetWindowContext(var frame: IOleInPlaceFrame;
  1280.   var doc: IOleInPlaceUIWindow; var rcPosRect: TRect;
  1281.   var rcClipRect: TRect; var frameInfo: TOleInPlaceFrameInfo): HResult;
  1282. var
  1283.   Origin: TPoint;
  1284. begin
  1285.   with FContainer do
  1286.   begin
  1287.     frame := FFrameForm.FOleInPlaceFrame;
  1288.     frame.AddRef;
  1289.     doc := nil;
  1290.     Origin := Parent.ScreenToClient(ClientOrigin);
  1291.     SetRect(rcPosRect, Origin.X, Origin.Y,
  1292.       Origin.X + ClientWidth, Origin.Y + ClientHeight);
  1293.     SetRect(rcClipRect, -16384, -16384, 16383, 16383);
  1294.     CreateAccelTable;
  1295.     with frameInfo do
  1296.     begin
  1297.       fMDIApp := False;
  1298.       hWndFrame := FFrameForm.FForm.Handle;
  1299.       hAccel := FAccelTable;
  1300.       cAccelEntries := FAccelCount;
  1301.     end;
  1302.   end;
  1303.   Result := S_OK;
  1304. end;
  1305.  
  1306. function TOleInPlaceSite.Scroll(const scrollExtent: TPoint): HResult;
  1307. begin
  1308.   Result := E_NOTIMPL;
  1309. end;
  1310.  
  1311. function TOleInPlaceSite.OnUIDeactivate(fUndoable: BOOL): HResult;
  1312. begin
  1313.   FContainer.FFrameForm.FOleInPlaceFrame.SetMenu(0, 0, 0);
  1314.   FContainer.FFrameForm.ClearBorderSpace;
  1315.   FContainer.SetUIActive(False);
  1316.   Result := S_OK;
  1317. end;
  1318.  
  1319. function TOleInPlaceSite.OnInPlaceDeactivate: HResult;
  1320. begin
  1321.   ReleaseObject(FContainer.FOleInPlaceActiveObject);
  1322.   ReleaseObject(FContainer.FOleInPlaceObject);
  1323.   Result := S_OK;
  1324. end;
  1325.  
  1326. function TOleInPlaceSite.DiscardUndoState: HResult;
  1327. begin
  1328.   Result := E_NOTIMPL;
  1329. end;
  1330.  
  1331. function TOleInPlaceSite.DeactivateAndUndo: HResult;
  1332. begin
  1333.   FContainer.FOleInPlaceObject.UIDeactivate;
  1334.   Result := S_OK;
  1335. end;
  1336.  
  1337. function TOleInPlaceSite.OnPosRectChange(const rcPosRect: TRect): HResult;
  1338. begin
  1339.   try
  1340.     FContainer.ObjectMoved(rcPosRect);
  1341.     FContainer.UpdateObjectRect;
  1342.   except
  1343.     Application.HandleException(Self);
  1344.   end;
  1345.   Result := S_OK;
  1346. end;
  1347.  
  1348. { TAdviseSink }
  1349.  
  1350. constructor TAdviseSink.Create(Container: TOleContainer);
  1351. begin
  1352.   FContainer := Container;
  1353. end;
  1354.  
  1355. function TAdviseSink.QueryInterface(const iid: TIID; var obj): HResult;
  1356. begin
  1357.   Result := FContainer.QueryInterface(iid, obj);
  1358. end;
  1359.  
  1360. function TAdviseSink.AddRef: Longint;
  1361. begin
  1362.   Result := FContainer.AddRef;
  1363. end;
  1364.  
  1365. function TAdviseSink.Release: Longint;
  1366. begin
  1367.   Result := FContainer.Release;
  1368. end;
  1369.  
  1370. procedure TAdviseSink.OnDataChange(var formatetc: TFormatEtc; var stgmed: TStgMedium);
  1371. begin
  1372.   FContainer.ObjectModified;
  1373. end;
  1374.  
  1375. procedure TAdviseSink.OnViewChange(dwAspect: Longint; lindex: Longint);
  1376. begin
  1377.   FContainer.ObjectViewChange(dwAspect);
  1378. end;
  1379.  
  1380. procedure TAdviseSink.OnRename(mk: IMoniker);
  1381. begin
  1382. end;
  1383.  
  1384. procedure TAdviseSink.OnSave;
  1385. begin
  1386. end;
  1387.  
  1388. procedure TAdviseSink.OnClose;
  1389. begin
  1390. end;
  1391.  
  1392. { TOleContainer }
  1393.  
  1394. constructor TOleContainer.Create(AOwner: TComponent);
  1395. const
  1396.   ContainerStyle = [csClickEvents, csSetCaption, csOpaque, csDoubleClicks];
  1397. begin
  1398.   inherited Create(AOwner);
  1399.   if NewStyleControls then
  1400.     ControlStyle := ContainerStyle else
  1401.     ControlStyle := ContainerStyle + [csFramed];
  1402.   Width := 121;
  1403.   Height := 121;
  1404.   TabStop := True;
  1405.   ParentColor := False;
  1406.   FAllowInPlace := True;
  1407.   FAutoActivate := aaDoubleClick;
  1408.   FAutoVerbMenu := True;
  1409.   FBorderStyle := bsSingle;
  1410.   FCopyOnSave := True;
  1411.   FOleClientSite := TOleClientSite.Create(Self);
  1412.   FOleInPlaceSite := TOleInPlaceSite.Create(Self);
  1413.   FAdviseSink := TAdviseSink.Create(Self);
  1414.   FDrawAspect := DVASPECT_CONTENT;
  1415. end;
  1416.  
  1417. destructor TOleContainer.Destroy;
  1418. begin
  1419.   DestroyObject;
  1420.   FAdviseSink.Free;
  1421.   FOleInPlaceSite.Free;
  1422.   FOleClientSite.Free;
  1423.   inherited Destroy;
  1424. end;
  1425.  
  1426. function TOleContainer.AddRef: Longint;
  1427. begin
  1428.   Inc(FRefCount);
  1429.   Result := FRefCount;
  1430. end;
  1431.  
  1432. procedure TOleContainer.AdjustBounds;
  1433. var
  1434.   Size: TPoint;
  1435.   Extra: Integer;
  1436. begin
  1437.   if not (csReading in ComponentState) and (FSizeMode = smAutoSize) and
  1438.     (FOleObject <> nil) then
  1439.   begin
  1440.     Size := HimetricToPixels(FViewSize);
  1441.     Extra := GetBorderWidth * 2;
  1442.     SetBounds(Left, Top, Size.X + Extra, Size.Y + Extra);
  1443.   end;
  1444. end;
  1445.  
  1446. function TOleContainer.ChangeIconDialog: Boolean;
  1447. var
  1448.   Data: TOleUIChangeIcon;
  1449. begin
  1450.   CheckObject;
  1451.   Result := False;
  1452.   FillChar(Data, SizeOf(Data), 0);
  1453.   Data.cbStruct := SizeOf(Data);
  1454.   Data.dwFlags := CIF_SELECTCURRENT;
  1455.   Data.hWndOwner := Application.Handle;
  1456.   Data.lpfnHook := OleDialogHook;
  1457.   OleCheck(FOleObject.GetUserClassID(Data.clsid));
  1458.   Data.hMetaPict := GetIconMetaPict;
  1459.   try
  1460.     if OleUIChangeIcon(Data) = OLEUI_OK then
  1461.     begin
  1462.       SetDrawAspect(True, Data.hMetaPict);
  1463.       Result := True;
  1464.     end;
  1465.   finally
  1466.     DestroyMetaPict(Data.hMetaPict);
  1467.   end;
  1468. end;
  1469.  
  1470. procedure TOleContainer.CheckObject;
  1471. begin
  1472.   if FOleObject = nil then
  1473.     raise EOleError.CreateRes(SEmptyContainer);
  1474. end;
  1475.  
  1476. procedure TOleContainer.Close;
  1477. begin
  1478.   CheckObject;
  1479.   OleCheck(FOleObject.Close(OLECLOSE_SAVEIFDIRTY));
  1480. end;
  1481.  
  1482. procedure TOleContainer.Copy;
  1483. begin
  1484.   Close;
  1485.   OleCheck(OleSetClipboard(TDataObject.Create(FOleObject)));
  1486. end;
  1487.  
  1488. procedure TOleContainer.CreateAccelTable;
  1489. var
  1490.   Menu: TMainMenu;
  1491. begin
  1492.   if FAccelTable = 0 then
  1493.   begin
  1494.     Menu := FFrameForm.FForm.Menu;
  1495.     if Menu <> nil then
  1496.       Menu.GetOle2AcceleratorTable(FAccelTable, FAccelCount, [0, 2, 4]);
  1497.   end;
  1498. end;
  1499.  
  1500. procedure TOleContainer.CreateLinkToFile(const FileName: string;
  1501.   Iconic: Boolean);
  1502. var
  1503.   CreateInfo: TCreateInfo;
  1504. begin
  1505.   CreateInfo.CreateType := ctLinkToFile;
  1506.   CreateInfo.ShowAsIcon := Iconic;
  1507.   CreateInfo.IconMetaPict := 0;
  1508.   CreateInfo.FileName := FileName;
  1509.   CreateObjectFromInfo(CreateInfo);
  1510. end;
  1511.  
  1512. procedure TOleContainer.CreateObject(const OleClassName: string;
  1513.   Iconic: Boolean);
  1514. var
  1515.   CreateInfo: TCreateInfo;
  1516. begin
  1517.   CreateInfo.CreateType := ctNewObject;
  1518.   CreateInfo.ShowAsIcon := Iconic;
  1519.   CreateInfo.IconMetaPict := 0;
  1520.   CreateInfo.ClassID := ProgIDToClassID(OleClassName);
  1521.   CreateObjectFromInfo(CreateInfo);
  1522. end;
  1523.  
  1524. procedure TOleContainer.CreateObjectFromFile(const FileName: string;
  1525.   Iconic: Boolean);
  1526. var
  1527.   CreateInfo: TCreateInfo;
  1528. begin
  1529.   CreateInfo.CreateType := ctFromFile;
  1530.   CreateInfo.ShowAsIcon := Iconic;
  1531.   CreateInfo.IconMetaPict := 0;
  1532.   CreateInfo.FileName := FileName;
  1533.   CreateObjectFromInfo(CreateInfo);
  1534. end;
  1535.  
  1536. procedure TOleContainer.CreateObjectFromInfo(const CreateInfo: TCreateInfo);
  1537. var
  1538.   Buffer: array[0..255] of WideChar;
  1539. begin
  1540.   DestroyObject;
  1541.   try
  1542.     CreateStorage;
  1543.     with CreateInfo do
  1544.     begin
  1545.       case CreateType of
  1546.         ctNewObject:
  1547.           OleCheck(OleCreate(ClassID, IID_IOleObject, OLERENDER_DRAW, nil,
  1548.             FOleClientSite, FStorage, FOleObject));
  1549.         ctFromFile:
  1550.           OleCheck(OleCreateFromFile(GUID_NULL, StringToWideChar(FileName,
  1551.             Buffer, SizeOf(Buffer) div 2), IID_IOleObject, OLERENDER_DRAW,
  1552.             nil, FOleClientSite, FStorage, FOleObject));
  1553.         ctLinkToFile:
  1554.           OleCheck(OleCreateLinkToFile(StringToWideChar(FileName, Buffer,
  1555.             SizeOf(Buffer) div 2), IID_IOleObject, OLERENDER_DRAW, nil,
  1556.             FOleClientSite, FStorage, FOleObject));
  1557.         ctFromData:
  1558.           OleCheck(OleCreateFromData(DataObject, IID_IOleObject,
  1559.             OLERENDER_DRAW, nil, FOleClientSite, FStorage, FOleObject));
  1560.         ctLinkFromData:
  1561.           OleCheck(OleCreateLinkFromData(DataObject, IID_IOleObject,
  1562.             OLERENDER_DRAW, nil, FOleClientSite, FStorage, FOleObject));
  1563.       end;
  1564.       FDrawAspect := DVASPECT_CONTENT;
  1565.       InitObject;
  1566.       FOleObject.SetExtent(DVASPECT_CONTENT, PixelsToHimetric(
  1567.         Point(ClientWidth, ClientHeight)));
  1568.       SetDrawAspect(ShowAsIcon, IconMetaPict);
  1569.       UpdateView;
  1570.     end;
  1571.   except
  1572.     DestroyObject;
  1573.     raise;
  1574.   end;
  1575. end;
  1576.  
  1577. procedure TOleContainer.CreateParams(var Params: TCreateParams);
  1578. begin
  1579.   inherited CreateParams(Params);
  1580.   if FBorderStyle = bsSingle then
  1581.     if NewStyleControls and Ctl3D then
  1582.       Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE else
  1583.       Params.Style := Params.Style or WS_BORDER;
  1584. end;
  1585.  
  1586. procedure TOleContainer.CreateStorage;
  1587. begin
  1588.   OleCheck(CreateILockBytesOnHGlobal(0, True, FLockBytes));
  1589.   OleCheck(StgCreateDocfileOnILockBytes(FLockBytes, STGM_READWRITE
  1590.     or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, FStorage));
  1591. end;
  1592.  
  1593. procedure TOleContainer.DblClick;
  1594. begin
  1595.   if FAutoActivate = aaDoubleClick then
  1596.     DoVerb(ovPrimary)
  1597.   else
  1598.     inherited;
  1599. end;
  1600.  
  1601. procedure TOleContainer.DefineProperties(Filer: TFiler);
  1602. begin
  1603.   inherited DefineProperties(Filer);
  1604.   Filer.DefineBinaryProperty('Data', LoadFromStream, SaveToStream,
  1605.     FOleObject <> nil);
  1606. end;
  1607.  
  1608. procedure TOleContainer.DesignModified;
  1609. var
  1610.   Form: TForm;
  1611. begin
  1612.   Form := GetParentForm(Self);
  1613.   if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
  1614. end;
  1615.  
  1616. procedure TOleContainer.DestroyAccelTable;
  1617. begin
  1618.   if FAccelTable <> 0 then
  1619.   begin
  1620.     DestroyAcceleratorTable(FAccelTable);
  1621.     FAccelTable := 0;
  1622.     FAccelCount := 0;
  1623.   end;
  1624. end;
  1625.  
  1626. procedure TOleContainer.DestroyObject;
  1627. var
  1628.   DataObject: IDataObject;
  1629. begin
  1630.   if FOleObject <> nil then
  1631.   begin
  1632.     SetViewAdviseSink(False);
  1633.     if FDataConnection <> 0 then
  1634.     begin
  1635.       FOleObject.QueryInterface(IID_IDataObject, DataObject);
  1636.       if DataObject <> nil then
  1637.       begin
  1638.         DataObject.DUnadvise(FDataConnection);
  1639.         DataObject.Release;
  1640.       end;
  1641.       FDataConnection := 0;
  1642.     end;
  1643.     FOleObject.Close(OLECLOSE_NOSAVE);
  1644.     Invalidate;
  1645.     ObjectModified;
  1646.   end;
  1647.   ReleaseObject(FOleObject);
  1648.   ReleaseObject(FStorage);
  1649.   ReleaseObject(FLockBytes);
  1650.   DestroyVerbs;
  1651.   DestroyAccelTable;
  1652.   if FDocForm <> nil then
  1653.   begin
  1654.     if FFrameForm <> FDocForm then FFrameForm.FContainers.Remove(Self);
  1655.     FDocForm.FContainers.Remove(Self);
  1656.     FFrameForm := nil;
  1657.     FDocForm := nil;
  1658.   end;
  1659. end;
  1660.  
  1661. procedure TOleContainer.DestroyVerbs;
  1662. begin
  1663.   FPopupVerbMenu.Free;
  1664.   FPopupVerbMenu := nil;
  1665.   FObjectVerbs.Free;
  1666.   FObjectVerbs := nil;
  1667. end;
  1668.  
  1669. procedure TOleContainer.DoEnter;
  1670. begin
  1671.   if FAutoActivate = aaGetFocus then DoVerb(ovShow);
  1672.   inherited;
  1673. end;
  1674.  
  1675. procedure TOleContainer.DoVerb(Verb: Integer);
  1676. begin
  1677.   CheckObject;
  1678.   if Verb >= 0 then
  1679.   begin
  1680.     if FObjectVerbs = nil then UpdateVerbs;
  1681.     if Verb >= FObjectVerbs.Count then
  1682.       raise EOleError.CreateRes(SInvalidVerb);
  1683.     Verb := Smallint(Integer(FObjectVerbs.Objects[Verb]) and $0000FFFF);
  1684.   end else
  1685.     if Verb = ovPrimary then Verb := 0;
  1686.   OleCheck(FOleObject.DoVerb(Verb, nil, FOleClientSite, 0,
  1687.     Parent.Handle, BoundsRect));
  1688. end;
  1689.  
  1690. function TOleContainer.GetBorderWidth: Integer;
  1691. begin
  1692.   if FBorderStyle = bsNone then
  1693.     Result := 0
  1694.   else
  1695.     if NewStyleControls and Ctl3D then
  1696.       Result := 2
  1697.     else
  1698.       Result := 1;
  1699. end;
  1700.  
  1701. function TOleContainer.GetCanPaste: Boolean;
  1702. var
  1703.   DataObject: IDataObject;
  1704. begin
  1705.   Result := False;
  1706.   if OleGetClipboard(DataObject) >= 0 then
  1707.   begin
  1708.     if (OleQueryCreateFromData(DataObject) = 0) or
  1709.       (OleQueryLinkFromData(DataObject) = 0) then Result := True;
  1710.     DataObject.Release;
  1711.   end;
  1712. end;
  1713.  
  1714. function TOleContainer.GetIconic: Boolean;
  1715. begin
  1716.   Result := FDrawAspect = DVASPECT_ICON;
  1717. end;
  1718.  
  1719. function TOleContainer.GetIconMetaPict: HGlobal;
  1720. var
  1721.   DataObject: IDataObject;
  1722.   FormatEtc: TFormatEtc;
  1723.   Medium: TStgMedium;
  1724.   ClassID: TCLSID;
  1725. begin
  1726.   CheckObject;
  1727.   Result := 0;
  1728.   if FDrawAspect = DVASPECT_ICON then
  1729.   begin
  1730.     FOleObject.QueryInterface(IID_IDataObject, DataObject);
  1731.     if DataObject <> nil then
  1732.     begin
  1733.       FormatEtc.cfFormat := CF_METAFILEPICT;
  1734.       FormatEtc.ptd := nil;
  1735.       FormatEtc.dwAspect := DVASPECT_ICON;
  1736.       FormatEtc.lIndex := -1;
  1737.       FormatEtc.tymed := TYMED_MFPICT;
  1738.       if DataObject.GetData(FormatEtc, Medium) >= 0 then
  1739.         Result := Medium.hMetaFilePict;
  1740.       DataObject.Release;
  1741.     end;
  1742.   end;
  1743.   if Result = 0 then
  1744.   begin
  1745.     OleCheck(FOleObject.GetUserClassID(ClassID));
  1746.     Result := OleGetIconOfClass(ClassID, nil, True);
  1747.   end;
  1748. end;
  1749.  
  1750. function TOleContainer.GetLinked: Boolean;
  1751. var
  1752.   OleLink: IOleLink;
  1753. begin
  1754.   CheckObject;
  1755.   Result := False;
  1756.   FOleObject.QueryInterface(IID_IOleLink, OleLink);
  1757.   if OleLink <> nil then
  1758.   begin
  1759.     Result := True;
  1760.     OleLink.Release;
  1761.   end;
  1762. end;
  1763.  
  1764. function TOleContainer.GetObjectDataSize: Integer;
  1765. var
  1766.   DataHandle: HGlobal;
  1767. begin
  1768.   if GetHGlobalFromILockBytes(FLockBytes, DataHandle) >= 0 then
  1769.     Result := GlobalSize(DataHandle) else
  1770.     Result := 0;
  1771. end;
  1772.  
  1773. function TOleContainer.GetObjectVerbs: TStrings;
  1774. begin
  1775.   if FObjectVerbs = nil then UpdateVerbs;
  1776.   Result := FObjectVerbs;
  1777. end;
  1778.  
  1779. function TOleContainer.GetOleClassName: string;
  1780. var
  1781.   ClassID: TCLSID;
  1782. begin
  1783.   CheckObject;
  1784.   OleCheck(FOleObject.GetUserClassID(ClassID));
  1785.   Result := ClassIDToProgID(ClassID);
  1786. end;
  1787.  
  1788. function TOleContainer.GetOleObject: Variant;
  1789. begin
  1790.   CheckObject;
  1791.   Result := VarFromInterface(FOleObject);
  1792. end;
  1793.  
  1794. function TOleContainer.GetPopupMenu: TPopupMenu;
  1795. var
  1796.   I: Integer;
  1797.   Item: TMenuItem;
  1798. begin
  1799.   if FAutoVerbMenu and (FOleObject <> nil) and (ObjectVerbs.Count > 0) then
  1800.   begin
  1801.     if FPopupVerbMenu = nil then
  1802.     begin
  1803.       FPopupVerbMenu := TPopupMenu.Create(Self);
  1804.       for I := 0 to ObjectVerbs.Count - 1 do
  1805.       begin
  1806.         Item := TMenuItem.Create(Self);
  1807.         Item.Caption := ObjectVerbs[I];
  1808.         Item.Tag := I;
  1809.         Item.OnClick := PopupVerbMenuClick;
  1810.         FPopupVerbMenu.Items.Add(Item);
  1811.       end;
  1812.     end;
  1813.     Result := FPopupVerbMenu;
  1814.   end else
  1815.     Result := inherited GetPopupMenu;
  1816. end;
  1817.  
  1818. function TOleContainer.GetPrimaryVerb: Integer;
  1819. begin
  1820.   if FObjectVerbs = nil then UpdateVerbs;
  1821.   for Result := 0 to FObjectVerbs.Count - 1 do
  1822.     if Integer(FObjectVerbs.Objects[Result]) and $0000FFFF = 0 then Exit;
  1823.   Result := 0;
  1824. end;
  1825.  
  1826. function TOleContainer.GetSourceDoc: string;
  1827. var
  1828.   OleLink: IOleLink;
  1829. begin
  1830.   CheckObject;
  1831.   Result := '';
  1832.   FOleObject.QueryInterface(IID_IOleLink, OleLink);
  1833.   if OleLink <> nil then
  1834.   begin
  1835.     Result := GetDisplayNameStr(OleLink);
  1836.     OleLink.Release;
  1837.   end;
  1838. end;
  1839.  
  1840. function TOleContainer.GetState: TObjectState;
  1841. begin
  1842.   if FOleObject = nil then
  1843.     Result := osEmpty
  1844.   else if FObjectOpen then
  1845.     Result := osOpen
  1846.   else if FUIActive then
  1847.     Result := osUIActive
  1848.   else if OleIsRunning(FOleObject) then
  1849.     Result := osRunning
  1850.   else
  1851.     Result := osLoaded;
  1852. end;
  1853.  
  1854. procedure TOleContainer.InitObject;
  1855. var
  1856.   DataObject: IDataObject;
  1857.   FormatEtc: TFormatEtc;
  1858.   AppNameBuf: array[0..127] of WideChar;
  1859.   DocNameBuf: array[0..127] of WideChar;
  1860. begin
  1861.   FDocForm := GetOleForm(ValidParentForm(Self));
  1862.   FFrameForm := FDocForm;
  1863.   FDocForm.FContainers.Add(Self);
  1864.   if FDocForm.FForm.FormStyle = fsMDIChild then
  1865.   begin
  1866.     FFrameForm := GetOleForm(Application.MainForm);
  1867.     FFrameForm.FContainers.Add(Self);
  1868.   end;
  1869.   SetViewAdviseSink(True);
  1870.   FOleObject.SetHostNames(
  1871.     StringToWideChar(Application.Title, AppNameBuf, SizeOf(AppNameBuf) div 2),
  1872.     StringToWideChar(Caption, DocNameBuf, SizeOf(DocNameBuf) div 2));
  1873.   OleSetContainedObject(FOleObject, True);
  1874.   FOleObject.QueryInterface(IID_IDataObject, DataObject);
  1875.   if DataObject <> nil then
  1876.   begin
  1877.     FormatEtc.cfFormat := 0;
  1878.     FormatEtc.ptd := nil;
  1879.     FormatEtc.dwAspect := -1;
  1880.     FormatEtc.lIndex := -1;
  1881.     FormatEtc.tymed := -1;
  1882.     DataObject.DAdvise(FormatEtc, ADVF_NODATA, FAdviseSink, FDataConnection);
  1883.     DataObject.Release;
  1884.   end;
  1885. end;
  1886.  
  1887. function TOleContainer.InsertObjectDialog: Boolean;
  1888. var
  1889.   Data: TOleUIInsertObject;
  1890.   NameBuffer: array[0..255] of Char;
  1891.   CreateInfo: TCreateInfo;
  1892. begin
  1893.   Result := False;
  1894.   FNewInserted := False;
  1895.   FillChar(Data, SizeOf(Data), 0);
  1896.   FillChar(NameBuffer, SizeOf(NameBuffer), 0);
  1897.   Data.cbStruct := SizeOf(Data);
  1898.   Data.dwFlags := IOF_SELECTCREATENEW;
  1899.   Data.hWndOwner := Application.Handle;
  1900.   Data.lpfnHook := OleDialogHook;
  1901.   Data.lpszFile := NameBuffer;
  1902.   Data.cchFile := SizeOf(NameBuffer);
  1903.   try
  1904.     if OleUIInsertObject(Data) = OLEUI_OK then
  1905.     begin
  1906.       if Data.dwFlags and IOF_SELECTCREATENEW <> 0 then
  1907.       begin
  1908.         CreateInfo.CreateType := ctNewObject;
  1909.         CreateInfo.ClassID := Data.clsid;
  1910.       end else
  1911.       begin
  1912.         if Data.dwFlags and IOF_CHECKLINK = 0 then
  1913.           CreateInfo.CreateType := ctFromFile else
  1914.           CreateInfo.CreateType := ctLinkToFile;
  1915.         CreateInfo.FileName := NameBuffer;
  1916.       end;
  1917.       CreateInfo.ShowAsIcon := Data.dwFlags and IOF_CHECKDISPLAYASICON <> 0;
  1918.       CreateInfo.IconMetaPict := Data.hMetaPict;
  1919.       CreateObjectFromInfo(CreateInfo);
  1920.       if CreateInfo.CreateType = ctNewObject then FNewInserted := True;
  1921.       Result := True;
  1922.     end;
  1923.   finally
  1924.     DestroyMetaPict(Data.hMetaPict);
  1925.   end;
  1926. end;
  1927.  
  1928. procedure TOleContainer.KeyDown(var Key: Word; Shift: TShiftState);
  1929. begin
  1930.   inherited KeyDown(Key, Shift);
  1931.   if (FAutoActivate <> aaManual) and (Key = VK_RETURN) then
  1932.   begin
  1933.     if ssCtrl in Shift then DoVerb(ovShow) else DoVerb(ovPrimary);
  1934.     Key := 0;
  1935.   end;
  1936. end;
  1937.  
  1938. procedure TOleContainer.LoadFromFile(const FileName: string);
  1939. var
  1940.   Stream: TStream;
  1941. begin
  1942.   Stream := TFileStream.Create(FileName, fmOpenRead);
  1943.   try
  1944.     LoadFromStream(Stream);
  1945.   finally
  1946.     Stream.Free;
  1947.   end;
  1948. end;
  1949.  
  1950. procedure TOleContainer.LoadFromStream(Stream: TStream);
  1951. var
  1952.   DataHandle: HGlobal;
  1953.   Buffer: Pointer;
  1954.   Header: TStreamHeader;
  1955. begin
  1956.   DestroyObject;
  1957.   Stream.ReadBuffer(Header, SizeOf(Header));
  1958.   if (Header.Signature <> StreamSignature) and not FOldStreamFormat then
  1959.     raise EOleError.CreateRes(SInvalidStreamFormat);
  1960.   DataHandle := GlobalAlloc(GMEM_MOVEABLE, Header.DataSize);
  1961.   if DataHandle = 0 then OutOfMemoryError;
  1962.   try
  1963.     Buffer := GlobalLock(DataHandle);
  1964.     try
  1965.       Stream.Read(Buffer^, Header.DataSize);
  1966.     finally
  1967.       GlobalUnlock(DataHandle);
  1968.     end;
  1969.     OleCheck(CreateILockBytesOnHGlobal(DataHandle, True, FLockBytes));
  1970.     DataHandle := 0;
  1971.     OleCheck(StgOpenStorageOnILockBytes(FLockBytes, nil, STGM_READWRITE or
  1972.       STGM_SHARE_EXCLUSIVE, nil, 0, FStorage));
  1973.     OleCheck(OleLoad(FStorage, IID_IOleObject, FOleClientSite, FOleObject));
  1974.     FDrawAspect := Header.DrawAspect;
  1975.     InitObject;
  1976.     UpdateView;
  1977.   except
  1978.     if DataHandle <> 0 then GlobalFree(DataHandle);
  1979.     DestroyObject;
  1980.     raise;
  1981.   end;
  1982. end;
  1983.  
  1984. procedure TOleContainer.MouseDown(Button: TMouseButton;
  1985.   Shift: TShiftState; X, Y: Integer);
  1986. begin
  1987.   if Button = mbLeft then SetFocus;
  1988.   inherited MouseDown(Button, Shift, X, Y);
  1989. end;
  1990.  
  1991. procedure TOleContainer.ObjectModified;
  1992. begin
  1993.   if not (csReading in ComponentState) then
  1994.   begin
  1995.     FModified := True;
  1996.     FModSinceSave := True;
  1997.     DesignModified;
  1998.   end;
  1999. end;
  2000.  
  2001. procedure TOleContainer.ObjectMoved(const ObjectRect: TRect);
  2002. var
  2003.   R: TRect;
  2004.   I: Integer;
  2005. begin
  2006.   if Assigned(FOnObjectMove) then
  2007.   begin
  2008.     R := ObjectRect;
  2009.     I := GetBorderWidth;
  2010.     InflateRect(R, I, I);
  2011.     FOnObjectMove(Self, R);
  2012.   end;
  2013. end;
  2014.  
  2015. function TOleContainer.ObjectPropertiesDialog: Boolean;
  2016. var
  2017.   ObjectProps: TOleUIObjectProps;
  2018.   PropSheet: TPropSheetHeader;
  2019.   GeneralProps: TOleUIGnrlProps;
  2020.   ViewProps: TOleUIViewProps;
  2021.   LinkProps: TOleUILinkProps;
  2022.   DialogCaption: string;
  2023. begin
  2024.   CheckObject;
  2025.   Result := False;
  2026.   FillChar(ObjectProps, SizeOf(ObjectProps), 0);
  2027.   FillChar(PropSheet, SizeOf(PropSheet), 0);
  2028.   FillChar(GeneralProps, SizeOf(GeneralProps), 0);
  2029.   FillChar(ViewProps, SizeOf(ViewProps), 0);
  2030.   FillChar(LinkProps, SizeOf(LinkProps), 0);
  2031.   try
  2032.     ObjectProps.cbStruct := SizeOf(ObjectProps);
  2033.     ObjectProps.dwFlags := OPF_DISABLECONVERT;
  2034.     ObjectProps.lpPS := @PropSheet;
  2035.     ObjectProps.lpObjInfo := TOleUIObjInfo.Create(Self);
  2036.     if Linked then
  2037.     begin
  2038.       ObjectProps.dwFlags := ObjectProps.dwFlags or OPF_OBJECTISLINK;
  2039.       ObjectProps.lpLinkInfo := TOleUILinkInfo.Create(Self);
  2040.     end;
  2041.     ObjectProps.lpGP := @GeneralProps;
  2042.     ObjectProps.lpVP := @ViewProps;
  2043.     ObjectProps.lpLP := @LinkProps;
  2044.     PropSheet.dwSize := SizeOf(PropSheet);
  2045.     PropSheet.hWndParent := Application.Handle;
  2046.     PropSheet.hInstance := HInstance;
  2047.     DialogCaption := FmtLoadStr(SPropDlgCaption, [GetFullNameStr(FOleObject)]);
  2048.     PropSheet.pszCaption := PChar(DialogCaption);
  2049.     GeneralProps.cbStruct := SizeOf(GeneralProps);
  2050.     GeneralProps.lpfnHook := OleDialogHook;
  2051.     ViewProps.cbStruct := SizeOf(ViewProps);
  2052.     ViewProps.dwFlags := VPF_DISABLESCALE;
  2053.     LinkProps.cbStruct := SizeOf(LinkProps);
  2054.     LinkProps.dwFlags := ELF_DISABLECANCELLINK;
  2055.     if OleUIObjectProperties(ObjectProps) = OLEUI_OK then Result := True;
  2056.   finally
  2057.     ObjectProps.lpLinkInfo.Free;
  2058.     ObjectProps.lpObjInfo.Free;
  2059.   end;
  2060. end;
  2061.  
  2062. procedure TOleContainer.ObjectShowWindow(Show: Boolean);
  2063. begin
  2064.   if FObjectOpen <> Show then
  2065.   begin
  2066.     FObjectOpen := Show;
  2067.     Invalidate;
  2068.   end;
  2069. end;
  2070.  
  2071. procedure TOleContainer.ObjectViewChange(Aspect: Longint);
  2072. begin
  2073.   if Aspect = FDrawAspect then UpdateView;
  2074. end;
  2075.  
  2076. procedure TOleContainer.Paint;
  2077. var
  2078.   W, H: Integer;
  2079.   S: TPoint;
  2080.   R: TRect;
  2081. begin
  2082.   Canvas.Brush.Style := bsSolid;
  2083.   Canvas.Brush.Color := Color;
  2084.   Canvas.FillRect(ClientRect);
  2085.   if FOleObject <> nil then
  2086.   begin
  2087.     W := ClientWidth;
  2088.     H := ClientHeight;
  2089.     S := HimetricToPixels(FViewSize);
  2090.     if (FDrawAspect = DVASPECT_CONTENT) and (FSizeMode = smScale) then
  2091.       if W * S.Y > H * S.X then
  2092.       begin
  2093.         S.X := S.X * H div S.Y;
  2094.         S.Y := H;
  2095.       end else
  2096.       begin
  2097.         S.Y := S.Y * W div S.X;
  2098.         S.X := W;
  2099.       end;
  2100.     if (FDrawAspect = DVASPECT_ICON) or (FSizeMode = smCenter) or
  2101.       (FSizeMode = smScale) then
  2102.     begin
  2103.       R.Left := (W - S.X) div 2;
  2104.       R.Top := (H - S.Y) div 2;
  2105.       R.Right := R.Left + S.X;
  2106.       R.Bottom := R.Top + S.Y;
  2107.     end
  2108.     else if FSizeMode = smClip then
  2109.       SetRect(R, 0, 0, S.X, S.Y)
  2110.     else
  2111.       SetRect(R, 0, 0, W, H);
  2112.     OleDraw(FOleObject, FDrawAspect, Canvas.Handle, R);
  2113.     if FObjectOpen then ShadeRect(Canvas.Handle, ClientRect);
  2114.   end;
  2115.   if FFocused then Canvas.DrawFocusRect(ClientRect);
  2116. end;
  2117.  
  2118. procedure TOleContainer.Paste;
  2119. var
  2120.   DataObject: IDataObject;
  2121.   Descriptor: PObjectDescriptor;
  2122.   FormatEtc: TFormatEtc;
  2123.   Medium: TStgMedium;
  2124.   CreateInfo: TCreateInfo;
  2125. begin
  2126.   if not CanPaste then Exit;
  2127.   OleCheck(OleGetClipboard(DataObject));
  2128.   try
  2129.     CreateInfo.CreateType := ctFromData;
  2130.     CreateInfo.ShowAsIcon := False;
  2131.     CreateInfo.IconMetaPict := 0;
  2132.     CreateInfo.DataObject := DataObject;
  2133.     FormatEtc.cfFormat := CFObjectDescriptor;
  2134.     FormatEtc.ptd := nil;
  2135.     FormatEtc.dwAspect := DVASPECT_CONTENT;
  2136.     FormatEtc.lIndex := -1;
  2137.     FormatEtc.tymed := TYMED_HGLOBAL;
  2138.     if DataObject.GetData(FormatEtc, Medium) >= 0 then
  2139.     begin
  2140.       Descriptor := GlobalLock(Medium.hGlobal);
  2141.       if Descriptor^.dwDrawAspect = DVASPECT_ICON then
  2142.         CreateInfo.ShowAsIcon := True;
  2143.       GlobalUnlock(Medium.hGlobal);
  2144.       ReleaseStgMedium(Medium);
  2145.     end;
  2146.     if CreateInfo.ShowAsIcon then
  2147.     begin
  2148.       FormatEtc.cfFormat := CF_METAFILEPICT;
  2149.       FormatEtc.ptd := nil;
  2150.       FormatEtc.dwAspect := DVASPECT_ICON;
  2151.       FormatEtc.lIndex := -1;
  2152.       FormatEtc.tymed := TYMED_MFPICT;
  2153.       if DataObject.GetData(FormatEtc, Medium) >= 0 then
  2154.         CreateInfo.IconMetaPict := Medium.hMetaFilePict;
  2155.     end;
  2156.     CreateObjectFromInfo(CreateInfo);
  2157.   finally
  2158.     DestroyMetaPict(CreateInfo.IconMetaPict);
  2159.     DataObject.Release;
  2160.   end;
  2161. end;
  2162.  
  2163. function TOleContainer.PasteSpecialDialog: Boolean;
  2164. const
  2165.   PasteFormatCount = 2;
  2166. var
  2167.   Data: TOleUIPasteSpecial;
  2168.   PasteFormats: array[0..PasteFormatCount - 1] of TOleUIPasteEntry;
  2169.   CreateInfo: TCreateInfo;
  2170. begin
  2171.   Result := False;
  2172.   if not CanPaste then Exit;
  2173.   FillChar(Data, SizeOf(Data), 0);
  2174.   FillChar(PasteFormats, SizeOf(PasteFormats), 0);
  2175.   Data.cbStruct := SizeOf(Data);
  2176.   Data.hWndOwner := Application.Handle;
  2177.   Data.lpfnHook := OleDialogHook;
  2178.   Data.arrPasteEntries := @PasteFormats;
  2179.   Data.cPasteEntries := PasteFormatCount;
  2180.   Data.arrLinkTypes := @CFLinkSource;
  2181.   Data.cLinkTypes := 1;
  2182.   PasteFormats[0].fmtetc.cfFormat := CFEmbeddedObject;
  2183.   PasteFormats[0].fmtetc.dwAspect := DVASPECT_CONTENT;
  2184.   PasteFormats[0].fmtetc.lIndex := -1;
  2185.   PasteFormats[0].fmtetc.tymed := TYMED_ISTORAGE;
  2186.   PasteFormats[0].lpstrFormatName := '%s';
  2187.   PasteFormats[0].lpstrResultText := '%s';
  2188.   PasteFormats[0].dwFlags := OLEUIPASTE_PASTE or OLEUIPASTE_ENABLEICON;
  2189.   PasteFormats[1].fmtetc.cfFormat := CFLinkSource;
  2190.   PasteFormats[1].fmtetc.dwAspect := DVASPECT_CONTENT;
  2191.   PasteFormats[1].fmtetc.lIndex := -1;
  2192.   PasteFormats[1].fmtetc.tymed := TYMED_ISTREAM;
  2193.   PasteFormats[1].lpstrFormatName := '%s';
  2194.   PasteFormats[1].lpstrResultText := '%s';
  2195.   PasteFormats[1].dwFlags := OLEUIPASTE_LINKTYPE1 or OLEUIPASTE_ENABLEICON;
  2196.   try
  2197.     if OleUIPasteSpecial(Data) = OLEUI_OK then
  2198.     begin
  2199.       if Data.fLink then
  2200.         CreateInfo.CreateType := ctLinkFromData else
  2201.         CreateInfo.CreateType := ctFromData;
  2202.       CreateInfo.ShowAsIcon := Data.dwFlags and PSF_CHECKDISPLAYASICON <> 0;
  2203.       CreateInfo.IconMetaPict := Data.hMetaPict;
  2204.       CreateInfo.DataObject := Data.lpSrcDataObj;
  2205.       CreateObjectFromInfo(CreateInfo);
  2206.       Result := True;
  2207.     end;
  2208.   finally
  2209.     DestroyMetaPict(Data.hMetaPict);
  2210.     ReleaseObject(Data.lpSrcDataObj);
  2211.   end;
  2212. end;
  2213.  
  2214. procedure TOleContainer.PopupVerbMenuClick(Sender: TObject);
  2215. begin
  2216.   DoVerb((Sender as TMenuItem).Tag);
  2217. end;
  2218.  
  2219. function TOleContainer.QueryInterface(const iid: TIID; var obj): HResult;
  2220. var
  2221.   P: IUnknown;
  2222. begin
  2223.   P := nil;
  2224.   if IsEqualIID(iid, IID_IUnknown) or
  2225.     IsEqualIID(iid, IID_IOleClientSite) then P := FOleClientSite else
  2226.   if IsEqualIID(iid, IID_IOleInPlaceSite) then P := FOleInPlaceSite else
  2227.   if IsEqualIID(iid, IID_IAdviseSink) then P := FAdviseSink;
  2228.   Pointer(obj) := P;
  2229.   if P = nil then Result := E_NOINTERFACE else
  2230.   begin
  2231.     P.AddRef;
  2232.     Result := S_OK;
  2233.   end;
  2234. end;
  2235.  
  2236. function TOleContainer.Release: Longint;
  2237. begin
  2238.   Dec(FRefCount);
  2239.   Result := FRefCount;
  2240. end;
  2241.  
  2242. procedure TOleContainer.Run;
  2243. begin
  2244.   CheckObject;
  2245.   OleCheck(OleRun(FOleObject));
  2246. end;
  2247.  
  2248. procedure TOleContainer.SaveObject;
  2249. var
  2250.   PersistStorage: IPersistStorage;
  2251. begin
  2252.   if FOleObject <> nil then
  2253.   begin
  2254.     OleCheck(FOleObject.QueryInterface(IID_IPersistStorage, PersistStorage));
  2255.     try
  2256.       OleCheck(OleSave(PersistStorage, FStorage, True));
  2257.       PersistStorage.SaveCompleted(nil);
  2258.     finally
  2259.       PersistStorage.Release;
  2260.     end;
  2261.     OleCheck(FStorage.Commit(STGC_DEFAULT));
  2262.     FModSinceSave := False;
  2263.   end;
  2264. end;
  2265.  
  2266. procedure TOleContainer.SaveToFile(const FileName: string);
  2267. var
  2268.   Stream: TStream;
  2269. begin
  2270.   Stream := TFileStream.Create(FileName, fmCreate);
  2271.   try
  2272.     SaveToStream(Stream);
  2273.   finally
  2274.     Stream.Free;
  2275.   end;
  2276. end;
  2277.  
  2278. procedure TOleContainer.SaveToStream(Stream: TStream);
  2279. var
  2280.   TempLockBytes: ILockBytes;
  2281.   TempStorage: IStorage;
  2282.   DataHandle: HGlobal;
  2283.   Buffer: Pointer;
  2284.   Header: TStreamHeader;
  2285.   R: TRect;
  2286. begin
  2287.   CheckObject;
  2288.   if FModSinceSave then SaveObject;
  2289.   TempLockBytes := nil;
  2290.   TempStorage := nil;
  2291.   try
  2292.     if FCopyOnSave then
  2293.     begin
  2294.       OleCheck(CreateILockBytesOnHGlobal(0, True, TempLockBytes));
  2295.       OleCheck(StgCreateDocfileOnILockBytes(TempLockBytes, STGM_READWRITE
  2296.         or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, TempStorage));
  2297.       OleCheck(FStorage.CopyTo(0, nil, nil, TempStorage));
  2298.       OleCheck(TempStorage.Commit(STGC_DEFAULT));
  2299.       OleCheck(GetHGlobalFromILockBytes(TempLockBytes, DataHandle));
  2300.     end else
  2301.       OleCheck(GetHGlobalFromILockBytes(FLockBytes, DataHandle));
  2302.     if FOldStreamFormat then
  2303.     begin
  2304.       R := BoundsRect;
  2305.       Header.PartRect.Left := R.Left;
  2306.       Header.PartRect.Top := R.Top;
  2307.       Header.PartRect.Right := R.Right;
  2308.       Header.PartRect.Bottom := R.Bottom;
  2309.     end else
  2310.     begin
  2311.       Header.Signature := StreamSignature;
  2312.       Header.DrawAspect := FDrawAspect;
  2313.     end;
  2314.     Header.DataSize := GlobalSize(DataHandle);
  2315.     Stream.WriteBuffer(Header, SizeOf(Header));
  2316.     Buffer := GlobalLock(DataHandle);
  2317.     try
  2318.       Stream.WriteBuffer(Buffer^, Header.DataSize);
  2319.     finally
  2320.       GlobalUnlock(DataHandle);
  2321.     end;
  2322.   finally
  2323.     ReleaseObject(TempStorage);
  2324.     ReleaseObject(TempLockBytes);
  2325.   end;
  2326. end;
  2327.  
  2328. procedure TOleContainer.SetBorderStyle(Value: TBorderStyle);
  2329. begin
  2330.   if FBorderStyle <> Value then
  2331.   begin
  2332.     FBorderStyle := Value;
  2333.     AdjustBounds;
  2334.     RecreateWnd;
  2335.   end;
  2336. end;
  2337.  
  2338. procedure TOleContainer.SetDrawAspect(Iconic: Boolean;
  2339.   IconMetaPict: HGlobal);
  2340. var
  2341.   OleCache: IOleCache;
  2342.   EnumStatData: IEnumStatData;
  2343.   OldAspect, AdviseFlags, Connection: Longint;
  2344.   TempMetaPict: HGlobal;
  2345.   FormatEtc: TFormatEtc;
  2346.   Medium: TStgMedium;
  2347.   ClassID: TCLSID;
  2348.   StatData: TStatData;
  2349. begin
  2350.   OldAspect := FDrawAspect;
  2351.   if Iconic then
  2352.   begin
  2353.     FDrawAspect := DVASPECT_ICON;
  2354.     AdviseFlags := ADVF_NODATA;
  2355.   end else
  2356.   begin
  2357.     FDrawAspect := DVASPECT_CONTENT;
  2358.     AdviseFlags := ADVF_PRIMEFIRST;
  2359.   end;
  2360.   if (FDrawAspect <> OldAspect) or (FDrawAspect = DVASPECT_ICON) then
  2361.   begin
  2362.     OleCheck(FOleObject.QueryInterface(IID_IOleCache, OleCache));
  2363.     try
  2364.       if FDrawAspect <> OldAspect then
  2365.       begin
  2366.         OleCheck(OleCache.EnumCache(EnumStatData));
  2367.         if EnumStatData <> nil then
  2368.           try
  2369.             while EnumStatData.Next(1, StatData, nil) = 0 do
  2370.               if StatData.formatetc.dwAspect = OldAspect then
  2371.                 OleCache.Uncache(StatData.dwConnection);
  2372.           finally
  2373.             EnumStatData.Release;
  2374.           end;
  2375.         FillChar(FormatEtc, SizeOf(FormatEtc), 0);
  2376.         FormatEtc.dwAspect := FDrawAspect;
  2377.         FormatEtc.lIndex := -1;
  2378.         OleCheck(OleCache.Cache(FormatEtc, AdviseFlags, Connection));
  2379.         SetViewAdviseSink(True);
  2380.       end;
  2381.       if FDrawAspect = DVASPECT_ICON then
  2382.       begin
  2383.         TempMetaPict := 0;
  2384.         if IconMetaPict = 0 then
  2385.         begin
  2386.           OleCheck(FOleObject.GetUserClassID(ClassID));
  2387.           TempMetaPict := OleGetIconOfClass(ClassID, nil, True);
  2388.           IconMetaPict := TempMetaPict;
  2389.         end;
  2390.         try
  2391.           FormatEtc.cfFormat := CF_METAFILEPICT;
  2392.           FormatEtc.ptd := nil;
  2393.           FormatEtc.dwAspect := DVASPECT_ICON;
  2394.           FormatEtc.lIndex := -1;
  2395.           FormatEtc.tymed := TYMED_MFPICT;
  2396.           Medium.tymed := TYMED_MFPICT;
  2397.           Medium.hMetaFilePict := IconMetaPict;
  2398.           Medium.unkForRelease := nil;
  2399.           OleCheck(OleCache.SetData(FormatEtc, Medium, False));
  2400.         finally
  2401.           DestroyMetaPict(TempMetaPict);
  2402.         end;
  2403.       end;
  2404.     finally
  2405.       OleCache.Release;
  2406.     end;
  2407.     if FDrawAspect = DVASPECT_CONTENT then UpdateObject;
  2408.     UpdateView;
  2409.   end;
  2410. end;
  2411.  
  2412. procedure TOleContainer.SetFocused(Value: Boolean);
  2413. begin
  2414.   if FFocused <> Value then
  2415.   begin
  2416.     FFocused := Value;
  2417.     if GetUpdateRect(Handle, PRect(nil)^, False) then
  2418.       Invalidate
  2419.     else
  2420.       Canvas.DrawFocusRect(ClientRect);
  2421.   end;
  2422. end;
  2423.  
  2424. procedure TOleContainer.SetIconic(Value: Boolean);
  2425. begin
  2426.   if GetIconic <> Value then
  2427.   begin
  2428.     CheckObject;
  2429.     SetDrawAspect(Value, 0);
  2430.   end;
  2431. end;
  2432.  
  2433. procedure TOleContainer.SetSizeMode(Value: TSizeMode);
  2434. begin
  2435.   if FSizeMode <> Value then
  2436.   begin
  2437.     FSizeMode := Value;
  2438.     AdjustBounds;
  2439.     Invalidate;
  2440.   end;
  2441. end;
  2442.  
  2443. procedure TOleContainer.SetUIActive(Active: Boolean);
  2444. var
  2445.   Form: TForm;
  2446. begin
  2447.   try
  2448.     FUIActive := Active;
  2449.     Form := GetParentForm(Self);
  2450.     if Form <> nil then
  2451.       if Active then
  2452.       begin
  2453.         if (Form.ActiveOleControl <> nil) and
  2454.           (Form.ActiveOleControl <> Self) then
  2455.           Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0);
  2456.         Form.ActiveOleControl := Self;
  2457.         SetFocus;
  2458.         if Assigned(FOnActivate) then FOnActivate(Self);
  2459.       end else
  2460.       begin
  2461.         if Form.ActiveOleControl = Self then Form.ActiveOleControl := nil;
  2462.         if Form.ActiveControl = Self then Windows.SetFocus(Handle);
  2463.         DestroyAccelTable;
  2464.         if Assigned(FOnDeactivate) then FOnDeactivate(Self);
  2465.       end;
  2466.   except
  2467.     Application.HandleException(Self);
  2468.   end;
  2469. end;
  2470.  
  2471. procedure TOleContainer.SetViewAdviseSink(Enable: Boolean);
  2472. var
  2473.   ViewObject: IViewObject;
  2474.   AdviseSink: IAdviseSink;
  2475. begin
  2476.   OleCheck(FOleObject.QueryInterface(IID_IViewObject, ViewObject));
  2477.   if Enable then AdviseSink := FAdviseSink else AdviseSink := nil;
  2478.   ViewObject.SetAdvise(FDrawAspect, 0, AdviseSink);
  2479.   ViewObject.Release;
  2480. end;
  2481.  
  2482. procedure TOleContainer.UpdateObject;
  2483. begin
  2484.   if FOleObject <> nil then
  2485.   begin
  2486.     OleCheck(FOleObject.Update);
  2487.     ObjectModified;
  2488.   end;
  2489. end;
  2490.  
  2491. procedure TOleContainer.UpdateObjectRect;
  2492. var
  2493.   P: TPoint;
  2494. begin
  2495.   if FOleInPlaceObject <> nil then
  2496.   begin
  2497.     P := Parent.ScreenToClient(ClientOrigin);
  2498.     FOleInPlaceObject.SetObjectRects(
  2499.       Rect(P.X, P.Y, P.X + ClientWidth, P.Y + ClientHeight),
  2500.       Rect(-16384, -16384, 16383, 16383));
  2501.   end;
  2502. end;
  2503.  
  2504. procedure TOleContainer.UpdateVerbs;
  2505. var
  2506.   EnumOleVerb: IEnumOleVerb;
  2507.   OleVerb: TOleVerb;
  2508.   VerbInfo: TVerbInfo;
  2509. begin
  2510.   CheckObject;
  2511.   DestroyVerbs;
  2512.   FObjectVerbs := TStringList.Create;
  2513.   if FOleObject.EnumVerbs(EnumOleVerb) = 0 then
  2514.     try
  2515.       while (EnumOleVerb.Next(1, OleVerb, nil) = 0) and
  2516.         (OleVerb.lVerb >= 0) and
  2517.         (OleVerb.grfAttribs and OLEVERBATTRIB_ONCONTAINERMENU <> 0) do
  2518.       begin
  2519.         VerbInfo.Verb := OleVerb.lVerb;
  2520.         VerbInfo.Flags := OleVerb.fuFlags;
  2521.         FObjectVerbs.AddObject(WideCharToString(OleVerb.lpszVerbName),
  2522.           TObject(VerbInfo));
  2523.       end;
  2524.     finally
  2525.       EnumOleVerb.Release;
  2526.     end;
  2527. end;
  2528.  
  2529. procedure TOleContainer.UpdateView;
  2530. var
  2531.   ViewObject2: IViewObject2;
  2532. begin
  2533.   if FOleObject.QueryInterface(IID_IViewObject2, ViewObject2) >= 0 then
  2534.   begin
  2535.     ViewObject2.GetExtent(FDrawAspect, -1, nil, FViewSize);
  2536.     ViewObject2.Release;
  2537.     AdjustBounds;
  2538.   end;
  2539.   Invalidate;
  2540.   ObjectModified;
  2541. end;
  2542.  
  2543. procedure TOleContainer.CMCtl3DChanged(var Message: TMessage);
  2544. begin
  2545.   if NewStyleControls and (FBorderStyle = bsSingle) then
  2546.   begin
  2547.     AdjustBounds;
  2548.     RecreateWnd;
  2549.   end;
  2550.   inherited;
  2551. end;
  2552.  
  2553. procedure TOleContainer.CMDocWindowActivate(var Message: TMessage);
  2554. begin
  2555.   if FDocForm.FForm.FormStyle = fsMDIChild then
  2556.   begin
  2557.     FOleInPlaceActiveObject.OnDocWindowActivate(LongBool(Message.WParam));
  2558.     if Message.WParam = 0 then
  2559.     begin
  2560.       FFrameForm.FOleInPlaceFrame.SetMenu(0, 0, 0);
  2561.       FFrameForm.ClearBorderSpace;
  2562.     end;
  2563.   end;
  2564. end;
  2565.  
  2566. procedure TOleContainer.CMUIDeactivate(var Message: TMessage);
  2567. begin
  2568.   if GetParentForm(Self).ActiveOleControl = Self then
  2569.     FOleInPlaceObject.UIDeactivate;
  2570. end;
  2571.  
  2572. procedure TOleContainer.WMKillFocus(var Message: TWMSetFocus);
  2573. begin
  2574.   inherited;
  2575.   SetFocused(False);
  2576. end;
  2577.  
  2578. procedure TOleContainer.WMSetFocus(var Message: TWMSetFocus);
  2579. var
  2580.   Window: HWnd;
  2581. begin
  2582.   inherited;
  2583.   if FUIActive and (FOleInPlaceObject.GetWindow(Window) = 0) then
  2584.     Windows.SetFocus(Window)
  2585.   else
  2586.     SetFocused(True);
  2587. end;
  2588.  
  2589. procedure TOleContainer.WMSize(var Message: TWMSize);
  2590. begin
  2591.   inherited;
  2592.   if not (csLoading in ComponentState) and Assigned(FOnResize) then
  2593.     FOnResize(Self);
  2594. end;
  2595.  
  2596. procedure TOleContainer.WMWindowPosChanged(var Message: TWMWindowPosChanged);
  2597. var
  2598.   R: TRect;
  2599. begin
  2600.   R := BoundsRect;
  2601.   inherited;
  2602.   if FUIActive and not EqualRect(BoundsRect, R) then UpdateObjectRect;
  2603. end;
  2604.  
  2605. { TOleInPlaceFrame }
  2606.  
  2607. constructor TOleInPlaceFrame.Create(OleForm: TOleForm);
  2608. begin
  2609.   FOleForm := OleForm;
  2610. end;
  2611.  
  2612. function TOleInPlaceFrame.QueryInterface(const iid: TIID; var obj): HResult;
  2613. begin
  2614.   if IsEqualIID(iid, IID_IUnknown) or
  2615.     IsEqualIID(iid, IID_IOleInPlaceFrame) then
  2616.   begin
  2617.     Pointer(obj) := Self;
  2618.     AddRef;
  2619.     Result := S_OK;
  2620.   end else
  2621.   begin
  2622.     Pointer(obj) := nil;
  2623.     Result := E_NOINTERFACE;
  2624.   end;
  2625. end;
  2626.  
  2627. function TOleInPlaceFrame.AddRef: Longint;
  2628. begin
  2629.   Result := FOleForm.AddRef;
  2630. end;
  2631.  
  2632. function TOleInPlaceFrame.Release: Longint;
  2633. begin
  2634.   Result := FOleForm.Release;
  2635. end;
  2636.  
  2637. function TOleInPlaceFrame.GetWindow(var wnd: HWnd): HResult;
  2638. begin
  2639.   wnd := FOleForm.FForm.Handle;
  2640.   Result := S_OK;
  2641. end;
  2642.  
  2643. function TOleInPlaceFrame.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  2644. begin
  2645.   Result := S_OK;
  2646. end;
  2647.  
  2648. function TOleInPlaceFrame.GetBorder(var rectBorder: TRect): HResult;
  2649. begin
  2650.   FOleForm.GetBorder(rectBorder);
  2651.   Result := S_OK;
  2652. end;
  2653.  
  2654. function TOleInPlaceFrame.RequestBorderSpace(const borderwidths: TRect): HResult;
  2655. begin
  2656.   if FOleForm.BorderSpaceAvailable(borderwidths) then
  2657.     Result := S_OK else
  2658.     Result := INPLACE_E_NOTOOLSPACE;
  2659. end;
  2660.  
  2661. function TOleInPlaceFrame.SetBorderSpace(pborderwidths: PRect): HResult;
  2662. begin
  2663.   if (pborderwidths = nil) or FOleForm.SetBorderSpace(pborderwidths^) then
  2664.     Result := S_OK else
  2665.     Result := INPLACE_E_NOTOOLSPACE;
  2666. end;
  2667.  
  2668. function TOleInPlaceFrame.SetActiveObject(activeObject: IOleInPlaceActiveObject;
  2669.   pszObjName: POleStr): HResult;
  2670. begin
  2671.   FOleForm.SetActiveObject(activeObject);
  2672.   Result := S_OK;
  2673. end;
  2674.  
  2675. function TOleInPlaceFrame.InsertMenus(hmenuShared: HMenu;
  2676.   var menuWidths: TOleMenuGroupWidths): HResult;
  2677. var
  2678.   Menu: TMainMenu;
  2679. begin
  2680.   Menu := FOleForm.FForm.Menu;
  2681.   if Menu <> nil then
  2682.     Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);
  2683.   Result := S_OK;
  2684. end;
  2685.  
  2686. function TOleInPlaceFrame.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  2687.   hwndActiveObject: HWnd): HResult;
  2688. var
  2689.   Menu: TMainMenu;
  2690. begin
  2691.   Menu := FOleForm.FForm.Menu;
  2692.   Result := S_OK;
  2693.   if Menu <> nil then
  2694.   begin
  2695.     Menu.SetOle2MenuHandle(hmenuShared);
  2696.     Result := OleSetMenuDescriptor(holemenu, Menu.WindowHandle,
  2697.       hwndActiveObject, nil, nil);
  2698.   end;
  2699. end;
  2700.  
  2701. function TOleInPlaceFrame.RemoveMenus(hmenuShared: HMenu): HResult;
  2702. begin
  2703.   while GetMenuItemCount(hmenuShared) > 0 do
  2704.     RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
  2705.   Result := S_OK;
  2706. end;
  2707.  
  2708. function TOleInPlaceFrame.SetStatusText(pszStatusText: POleStr): HResult;
  2709. var
  2710.   StatusText: string;
  2711. begin
  2712.   if pszStatusText <> nil then
  2713.     StatusText := WideCharToString(pszStatusText) else
  2714.     StatusText := '';
  2715.   Application.Hint := StatusText;
  2716.   Result := S_OK;
  2717. end;
  2718.  
  2719. function TOleInPlaceFrame.EnableModeless(fEnable: BOOL): HResult;
  2720. begin
  2721.   Result := S_OK;
  2722. end;
  2723.  
  2724. function TOleInPlaceFrame.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
  2725. var
  2726.   Menu: TMainMenu;
  2727. begin
  2728.   Menu := FOleForm.FForm.Menu;
  2729.   if (Menu <> nil) and Menu.DispatchCommand(wID) then
  2730.     Result := S_OK else
  2731.     Result := S_FALSE;
  2732. end;
  2733.  
  2734. { TOleForm }
  2735.  
  2736. constructor TOleForm.Create(Form: TForm);
  2737. begin
  2738.   FRefCount := 1;
  2739.   FForm := Form;
  2740.   FOleInPlaceFrame := TOleInPlaceFrame.Create(Self);
  2741.   FContainers := TList.Create;
  2742.   FHiddenControls := TList.Create;
  2743.   FForm.OleFormObject := Self;
  2744. end;
  2745.  
  2746. destructor TOleForm.Destroy;
  2747. begin
  2748.   if FForm <> nil then FForm.OleFormObject := nil;
  2749.   FHiddenControls.Free;
  2750.   FContainers.Free;
  2751.   FOleInPlaceFrame.Free;
  2752. end;
  2753.  
  2754. function TOleForm.AddRef: Longint;
  2755. begin
  2756.   Inc(FRefCount);
  2757.   Result := FRefCount;
  2758. end;
  2759.  
  2760. function TOleForm.BorderSpaceAvailable(const BorderWidths: TRect): Boolean;
  2761. var
  2762.   I: Integer;
  2763. begin
  2764.   Result := True;
  2765.   if FForm.FormStyle = fsMDIForm then Exit;
  2766.   for I := 0 to FForm.ControlCount - 1 do
  2767.     with FForm.Controls[I] do
  2768.       if Visible and (Align = alClient) then Exit;
  2769.   Result := False;
  2770. end;
  2771.  
  2772. procedure TOleForm.ClearBorderSpace;
  2773. var
  2774.   I: Integer;
  2775. begin
  2776.   FForm.DisableAlign;
  2777.   for I := 0 to 3 do
  2778.   begin
  2779.     FSpacers[I].Free;
  2780.     FSpacers[I] := nil;
  2781.   end;
  2782.   for I := 0 to FHiddenControls.Count - 1 do
  2783.     TControl(FHiddenControls[I]).Visible := True;
  2784.   FHiddenControls.Clear;
  2785.   FForm.EnableAlign;
  2786. end;
  2787.  
  2788. procedure TOleForm.GetBorder(var BorderRect: TRect);
  2789. var
  2790.   I: Integer;
  2791.   Control: TControl;
  2792. begin
  2793.   BorderRect := FForm.ClientRect;
  2794.   for I := 0 to FForm.ControlCount - 1 do
  2795.   begin
  2796.     Control := FForm.Controls[I];
  2797.     if Control.Visible and not IsSpacer(Control) and
  2798.       not IsToolControl(Control) then
  2799.       case Control.Align of
  2800.         alLeft: Inc(BorderRect.Left, Control.Width);
  2801.         alRight: Dec(BorderRect.Right, Control.Width);
  2802.         alTop: Inc(BorderRect.Top, Control.Height);
  2803.         alBottom: Dec(BorderRect.Bottom, Control.Height);
  2804.       end;
  2805.   end;
  2806. end;
  2807.  
  2808. function TOleForm.IsSpacer(Control: TControl): Boolean;
  2809. var
  2810.   I: Integer;
  2811. begin
  2812.   for I := 0 to 3 do
  2813.     if Control = FSpacers[I] then
  2814.     begin
  2815.       Result := True;
  2816.       Exit;
  2817.     end;
  2818.   Result := False;
  2819. end;
  2820.  
  2821. function TOleForm.IsToolControl(Control: TControl): Boolean;
  2822. begin
  2823.   Result := Control.Visible and
  2824.     (Control.Align in [alTop, alBottom, alLeft, alRight]) and
  2825.     (Control.Perform(CM_ISTOOLCONTROL, 0, 0) <> 0);
  2826. end;
  2827.  
  2828. procedure TOleForm.OnDestroy;
  2829. var
  2830.   I: Integer;
  2831. begin
  2832.   for I := FContainers.Count - 1 downto 0 do
  2833.     TOleContainer(FContainers[I]).DestroyObject;
  2834. end;
  2835.  
  2836. procedure TOleForm.OnResize;
  2837. var
  2838.   BorderRect: TRect;
  2839. begin
  2840.   if (FActiveObject <> nil) and (FForm.WindowState <> wsMinimized) and
  2841.     ((FForm.ClientWidth <> FSaveWidth) or
  2842.     (FForm.ClientHeight <> FSaveHeight)) then
  2843.   begin
  2844.     GetBorder(BorderRect);
  2845.     FActiveObject.ResizeBorder(BorderRect, FOleInPlaceFrame, True);
  2846.     FSaveWidth := FForm.ClientWidth;
  2847.     FSaveHeight := FForm.ClientHeight;
  2848.   end;
  2849. end;
  2850.  
  2851. function TOleForm.Release: Longint;
  2852. begin
  2853.   Dec(FRefCount);
  2854.   Result := FRefCount;
  2855. end;
  2856.  
  2857. procedure TOleForm.SetActiveObject(ActiveObject: IOleInPlaceActiveObject);
  2858. var
  2859.   Window, ParentWindow: HWnd;
  2860. begin
  2861.   if FActiveObject <> nil then FActiveObject.Release;
  2862.   FActiveObject := ActiveObject;
  2863.   if FActiveObject <> nil then
  2864.   begin
  2865.     FActiveObject.AddRef;
  2866.     if FActiveObject.GetWindow(Window) = 0 then
  2867.       while True do
  2868.       begin
  2869.         ParentWindow := GetParent(Window);
  2870.         if ParentWindow = 0 then Break;
  2871.         if FindControl(ParentWindow) <> nil then
  2872.         begin
  2873.           SetWindowPos(Window, HWND_TOP, 0, 0, 0, 0,
  2874.             SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
  2875.           Break;
  2876.         end;
  2877.         Window := ParentWindow;
  2878.       end;
  2879.     FSaveWidth := FForm.ClientWidth;
  2880.     FSaveHeight := FForm.ClientHeight;
  2881.   end;
  2882. end;
  2883.  
  2884. function TOleForm.SetBorderSpace(const BorderWidths: TRect): Boolean;
  2885. type
  2886.   TRectArray = array[0..3] of Integer;
  2887. const
  2888.   Alignments: array[0..3] of TAlign = (alLeft, alTop, alRight, alBottom);
  2889. var
  2890.   I, J, Size: Integer;
  2891.   Control, Spacer: TControl;
  2892. begin
  2893.   if not BorderSpaceAvailable(BorderWidths) then
  2894.   begin
  2895.     Result := False;
  2896.     Exit;
  2897.   end;
  2898.   FForm.DisableAlign;
  2899.   for I := 0 to FForm.ControlCount - 1 do
  2900.   begin
  2901.     Control := FForm.Controls[I];
  2902.     if IsToolControl(Control) then
  2903.     begin
  2904.       Control.Visible := False;
  2905.       FHiddenControls.Add(Control);
  2906.     end;
  2907.   end;
  2908.   for I := 0 to 3 do
  2909.   begin
  2910.     Size := TRectArray(BorderWidths)[I];
  2911.     if Size > 0 then
  2912.     begin
  2913.       Spacer := FSpacers[I];
  2914.       if Spacer = nil then
  2915.       begin
  2916.         Spacer := TControl.Create(FForm);
  2917.         if I < 2 then J := 10000 else J := -10000;
  2918.         if Odd(I) then Spacer.Top := J else Spacer.Left := J;
  2919.         Spacer.Align := Alignments[I];
  2920.         Spacer.Parent := FForm;
  2921.         FSpacers[I] := Spacer;
  2922.       end;
  2923.       if Odd(I) then Spacer.Height := Size else Spacer.Width := Size;
  2924.     end;
  2925.   end;
  2926.   FForm.EnableAlign;
  2927.   Result := True;
  2928. end;
  2929.  
  2930. { Initialization }
  2931.  
  2932. procedure Initialize;
  2933. var
  2934.   DC: HDC;
  2935. begin
  2936.   DC := GetDC(0);
  2937.   PixPerInch.X := GetDeviceCaps(DC, LOGPIXELSX);
  2938.   PixPerInch.Y := GetDeviceCaps(DC, LOGPIXELSY);
  2939.   ReleaseDC(0, DC);
  2940.   CFObjectDescriptor := RegisterClipboardFormat('Object Descriptor');
  2941.   CFEmbeddedObject := RegisterClipboardFormat('Embedded Object');
  2942.   CFLinkSource := RegisterClipboardFormat('Link Source');
  2943.   DataFormats[0].cfFormat := CFEmbeddedObject;
  2944.   DataFormats[0].dwAspect := DVASPECT_CONTENT;
  2945.   DataFormats[0].lIndex := -1;
  2946.   DataFormats[0].tymed := TYMED_ISTORAGE;
  2947.   DataFormats[1].cfFormat := CFObjectDescriptor;
  2948.   DataFormats[1].dwAspect := DVASPECT_CONTENT;
  2949.   DataFormats[1].lIndex := -1;
  2950.   DataFormats[1].tymed := TYMED_HGLOBAL;
  2951. end;
  2952.  
  2953. begin
  2954.   Initialize;
  2955. end.
  2956.