olectnrs.pas

这是不可多得的源代码

{*******************************************************}
{                                                       }
{       Borland Delphi Visual Component Library         }
{                                                       }
{  Copyright (c) 1995-2001 Borland Software Corporation }
{                                                       }
{*******************************************************}

(*$HPPEMIT '#include <DocObj.h>'*)

unit OleCtnrs;

{$T-,H+,X+}
{$WARN SYMBOL_PLATFORM OFF}

interface

uses Windows, Messages, CommCtrl, ActiveX, OleDlg, SysUtils, Classes,
  Controls, Forms, Menus, Graphics, ComObj;

const
  ovShow = -1;
  ovOpen = -2;
  ovHide = -3;
  ovUIActivate = -4;
  ovInPlaceActivate = -5;
  ovDiscardUndoState = -6;
  ovPrimary = -65536;

type
  TOleContainer = class;
  TOleForm = class;

  IVCLFrameForm = interface(IOleInPlaceFrame)
    ['{CD02E1C0-52DA-11D0-9EA6-0020AF3D82DA}']
    procedure AddContainer(Instance: TOleContainer);
    procedure RemoveContainer(Instance: TOleContainer);
    procedure ClearBorderSpace;
    function Form: TCustomForm;
  end;

  TAutoActivate = (aaManual, aaGetFocus, aaDoubleClick);

  TSizeMode = (smClip, smCenter, smScale, smStretch, smAutoSize);

  TObjectState = (osEmpty, osLoaded, osRunning, osOpen, osInPlaceActive,
    osUIActive);

  TCreateType = (ctNewObject, ctFromFile, ctLinkToFile, ctFromData,
    ctLinkFromData);

  TCreateInfo = record
    CreateType: TCreateType;
    ShowAsIcon: Boolean;
    IconMetaPict: HGlobal;
    ClassID: TCLSID;
    FileName: WideString;
    DataObject: IDataObject;
  end;

  TVerbInfo = packed record
    Verb: Smallint;
    Flags: Word;
  end;

  TObjectMoveEvent = procedure(OleContainer: TOleContainer;
    const Bounds: TRect) of object;

  TOleContainer = class(TCustomControl, IUnknown, IOleClientSite,
    IOleInPlaceSite, IAdviseSink, IOleDocumentSite, IOleUIObjInfo)
  private
    FRefCount: Longint;
    FLockBytes: ILockBytes;
    FStorage: IStorage;
    FOleObject: IOleObject;
    FDrawAspect: Longint;
    FViewSize: TPoint;
    FObjectVerbs: TStringList;
    FDataConnection: Longint;
    FDocForm: IVCLFrameForm;
    FFrameForm: IVCLFrameForm;
    FOleInPlaceObject: IOleInPlaceObject;
    FOleInPlaceActiveObject: IOleInPlaceActiveObject;
    FAccelTable: HAccel;
    FAccelCount: Integer;
    FPopupVerbMenu: TPopupMenu;
    FAllowInPlace: Boolean;
    FAllowActiveDoc: Boolean;
    FAutoActivate: TAutoActivate;
    FAutoVerbMenu: Boolean;
    FBorderStyle: TBorderStyle;
    FCopyOnSave: Boolean;
    FOldStreamFormat: Boolean;
    FSizeMode: TSizeMode;
    FObjectOpen: Boolean;
    FUIActive: Boolean;
    FModified: Boolean;
    FModSinceSave: Boolean;
    FFocused: Boolean;
    FNewInserted: Boolean;
    FOnActivate: TNotifyEvent;
    FOnDeactivate: TNotifyEvent;
    FOnObjectMove: TObjectMoveEvent;
    FOnResize: TNotifyEvent;
    FDocView: IOleDocumentView;
    FDocObj: Boolean;
    { IOleClientSite }
    function SaveObject: HResult; stdcall;
    function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
      out mk: IMoniker): HResult; stdcall;
    function GetContainer(out container: IOleContainer): HResult; stdcall;
    function ShowObject: HResult; stdcall;
    function OnShowWindow(fShow: BOOL): HResult; stdcall;
    function RequestNewObjectLayout: HResult; stdcall;
    { IOleInPlaceSite }
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    function GetWindow(out wnd: HWnd): HResult; stdcall;
    function CanInPlaceActivate: HResult; stdcall;
    function OnInPlaceActivate: HResult; stdcall;
    function OnUIActivate: HResult; stdcall;
    function GetWindowContext(out frame: IOleInPlaceFrame;
      out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
      out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
      stdcall;
    function Scroll(scrollExtent: TPoint): HResult; stdcall;
    function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
    function OnInPlaceDeactivate: HResult; stdcall;
    function DiscardUndoState: HResult; stdcall;
    function DeactivateAndUndo: HResult; stdcall;
    function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
    { IAdviseSink }
    procedure OnDataChange(const formatetc: TFormatEtc;
      const stgmed: TStgMedium); stdcall;
    procedure OnViewChange(dwAspect: Longint; lindex: Longint); stdcall;
    procedure OnRename(const mk: IMoniker); stdcall;
    procedure OnSave; stdcall;
    procedure OnClose; stdcall;
    { IOleDocumentSite }
    function ActivateMe(View: IOleDocumentView): HRESULT; stdcall;
    { IOleUIObjInfo }
    function GetObjectInfo(dwObject: Longint;
      var dwObjSize: Longint; var lpszLabel: PChar;
      var lpszType: PChar; var lpszShortType: PChar;
      var lpszLocation: PChar): HResult; stdcall;
    function GetConvertInfo(dwObject: Longint; var ClassID: TCLSID;
      var wFormat: Word; var ConvertDefaultClassID: TCLSID;
      var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult; stdcall;
    function ConvertObject(dwObject: Longint;
      const clsidNew: TCLSID): HResult; stdcall;
    function GetViewInfo(dwObject: Longint; var hMetaPict: HGlobal;
      var dvAspect: Longint; var nCurrentScale: Integer): HResult; stdcall;
    function SetViewInfo(dwObject: Longint; hMetaPict: HGlobal;
      dvAspect: Longint; nCurrentScale: Integer;
      bRelativeToOrig: BOOL): HResult; stdcall;
    { TOleContainer }
    procedure AdjustBounds;
    procedure CheckObject;
    procedure CreateAccelTable;
    procedure CreateStorage;
    procedure DesignModified;
    procedure DestroyAccelTable;
    procedure DestroyVerbs;
    function GetBorderWidth: Integer;
    function GetCanPaste: Boolean;
    function GetIconic: Boolean;
    function GetLinked: Boolean;
    function GetObjectDataSize: Integer;
    function GetObjectVerbs: TStrings;
    function GetOleClassName: string;
    function GetOleObject: Variant;
    function GetPrimaryVerb: Integer;
    function GetSourceDoc: string;
    function GetState: TObjectState;
    procedure InitObject;
    procedure ObjectMoved(const ObjectRect: TRect);
    procedure PopupVerbMenuClick(Sender: TObject);
    procedure SetBorderStyle(Value: TBorderStyle);
    procedure SetDrawAspect(Iconic: Boolean; IconMetaPict: HGlobal);
    procedure SetFocused(Value: Boolean);
    procedure SetIconic(Value: Boolean);
    procedure SetSizeMode(Value: TSizeMode);
    procedure SetUIActive(Active: Boolean);
    procedure SetViewAdviseSink(Enable: Boolean);
    procedure UpdateObjectRect;
    procedure UpdateView;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
    procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
    procedure WMKillFocus(var Message: TWMSetFocus); message WM_KILLFOCUS;
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
  protected
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; override; stdcall;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    procedure Changed; dynamic;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure DblClick; override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DoEnter; override;
    function GetPopupMenu: TPopupMenu; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function ChangeIconDialog: Boolean;
    procedure Close;
    procedure Copy;
    procedure CreateLinkToFile(const FileName: string; Iconic: Boolean);
    procedure CreateObject(const OleClassName: string; Iconic: Boolean);
    procedure CreateObjectFromFile(const FileName: string; Iconic: Boolean);
    procedure CreateObjectFromInfo(const CreateInfo: TCreateInfo);
    procedure DestroyObject;
    procedure DoVerb(Verb: Integer);
    function GetIconMetaPict: HGlobal;
    function InsertObjectDialog: Boolean;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream);
    function ObjectPropertiesDialog: Boolean;
    procedure Paste;
    function PasteSpecialDialog: Boolean;
    procedure Run;
    procedure SaveAsDocument(const FileName: string);
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream);
    procedure UpdateObject;
    procedure UpdateVerbs;
    property CanPaste: Boolean read GetCanPaste;
    property Linked: Boolean read GetLinked;
    property Modified: Boolean read FModified write FModified;
    property NewInserted: Boolean read FNewInserted;
    property ObjectVerbs: TStrings read GetObjectVerbs;
    property OleClassName: string read GetOleClassName;
    property OleObject: Variant read GetOleObject;
    property OleObjectInterface: IOleObject read FOleObject;
    property PrimaryVerb: Integer read GetPrimaryVerb;
    property SourceDoc: string read GetSourceDoc;
    property State: TObjectState read GetState;
    property StorageInterface: IStorage read FStorage;
  published
    property AllowInPlace: Boolean read FAllowInPlace write FAllowInPlace default True;
    property AllowActiveDoc: Boolean read FAllowActiveDoc write FAllowActiveDoc default True;
    property AutoActivate: TAutoActivate read FAutoActivate write FAutoActivate default aaDoubleClick;
    property AutoVerbMenu: Boolean read FAutoVerbMenu write FAutoVerbMenu default True;
    property Align;
    property Anchors;
    property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle default bsSingle;
    property Caption;
    property Color;
    property Constraints;
    property CopyOnSave: Boolean read FCopyOnSave write FCopyOnSave default True;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Iconic: Boolean read GetIconic write SetIconic stored False;
    property OldStreamFormat: Boolean read FOldStreamFormat write FOldStreamFormat default False;
    property ParentColor default False;
    property ParentCtl3D;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property SizeMode: TSizeMode read FSizeMode write SetSizeMode default smClip;
    property TabOrder;
    property TabStop default True;
    property Visible;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnObjectMove: TObjectMoveEvent read FOnObjectMove write FOnObjectMove;
    property OnResize: TNotifyEvent read FOnResize write FOnResize;
    property OnStartDrag;
  end;

  TOleForm = class(TInterfacedObject, IOleForm, IOleWindow, IOleInPlaceUIWindow,
    IOleInPlaceFrame, IVCLFrameForm)
  private
    FForm: TCustomForm;
    FContainers: TList;
    FActiveObject: IOleInPlaceActiveObject;
    FSaveWidth: Integer;
    FSaveHeight: Integer;
    FHiddenControls: TList;
    FSpacers: array[0..3] of TControl;
    { IOleForm }
    procedure OnDestroy;
    procedure OnResize;
    { IOleWindow }
    function GetWindow(out wnd: HWnd): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    { IOleInPlaceUIWindow }
    function GetBorder(out BorderRect: TRect): HResult; stdcall;
    function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
    function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
    function SetActiveObject(const ActiveObject: IOleInPlaceActiveObject;
      pszObjName: POleStr): HResult; stdcall;
    { IOleInPlaceFrame }
    function InsertMenus(hmenuShared: HMenu;
      var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
    function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
      hwndActiveObject: HWnd): HResult; stdcall;
    function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
    function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
    function TranslateAccelerator(var msg: TMsg; wID: Word): HResult; stdcall;
    { IVCLFrameForm }
    procedure AddContainer(Instance: TOleContainer);
    procedure RemoveContainer(Instance: TOleContainer);
    function Form: TCustomForm;
    procedure ClearBorderSpace;
    { TOleForm }
    function IsSpacer(Control: TControl): Boolean;
    function IsToolControl(Control: TControl): Boolean;
  public
    constructor Create(Form: TCustomForm);
    destructor Destroy; override;
  end;

procedure DestroyMetaPict(MetaPict: HGlobal);

implementation

uses OleConst;

const
  DataFormatCount = 2;
  StreamSignature = $434F4442; {'BDOC'}

type
  TStreamHeader = record
    case Integer of
      0: ( { New }
        Signature: Integer;
        DrawAspect: Integer;
        DataSize: Integer);
      1: ( { Old }
        PartRect: TSmallRect);
  end;

{ Private variables }

var
  PixPerInch: TPoint;
  CFObjectDescriptor: Integer;
  CFEmbeddedObject: Integer;
  CFLinkSource: Integer;
  DataFormats: array[0..DataFormatCount - 1] of TFormatEtc;

{ Return length of PWideChar string }

function WStrLen(Str: PWideChar): Integer;
begin
  Result := 0;
  while Str[Result] <> #0 do Inc(Result);
end;

{ Convert point from pixels to himetric }

function PixelsToHimetric(const P: TPoint): TPoint;
begin
  Result.X := MulDiv(P.X, 2540, PixPerInch.X);
  Result.Y := MulDiv(P.Y, 2540, PixPerInch.Y);
end;

{ Convert point from himetric to pixels }

function HimetricToPixels(const P: TPoint): TPoint;
begin
  Result.X := MulDiv(P.X, PixPerInch.X, 2540);
  Result.Y := MulDiv(P.Y, PixPerInch.Y, 2540);
end;

{ Center the given window on the screen }

procedure CenterWindow(Wnd: HWnd);
var
  Rect: TRect;
begin
  GetWindowRect(Wnd, Rect);
  SetWindowPos(Wnd, 0,
    (GetSystemMetrics(SM_CXSCREEN) - Rect.Right + Rect.Left) div 2,
    (GetSystemMetrics(SM_CYSCREEN) - Rect.Bottom + Rect.Top) div 3,
    0, 0, SWP_NOACTIVATE or SWP_NOSIZE or SWP_NOZORDER);
end;

{ Generic dialog hook. Centers the dialog on the screen in response to
  the WM_INITDIALOG message }

function OleDialogHook(Wnd: HWnd; Msg, WParam, LParam: Longint): Longint; stdcall;
begin
  Result := 0;
  if Msg = WM_INITDIALOG then
  begin
    if GetWindowLong(Wnd, GWL_STYLE) and WS_CHILD <> 0 then
      Wnd := GetWindowLong(Wnd, GWL_HWNDPARENT);
    CenterWindow(Wnd);
    Result := 1;
  end;
end;

{ Destroy a metafile picture }

procedure DestroyMetaPict(MetaPict: HGlobal);
begin
  if MetaPict <> 0 then
  begin
    DeleteMetaFile(PMetaFilePict(GlobalLock(MetaPict))^.hMF);
    GlobalUnlock(MetaPict);
    GlobalFree(MetaPict);
  end;
end;

{ Shade rectangle }

procedure ShadeRect(DC: HDC; const Rect: TRect);
const
  HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
var
  Bitmap: HBitmap;
  SaveBrush: HBrush;
  SaveTextColor, SaveBkColor: TColorRef;
begin
  Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  SaveTextColor := SetTextColor(DC, clWhite);
  SaveBkColor := SetBkColor(DC, clBlack);
  with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
  SetBkColor(DC, SaveBkColor);
  SetTextColor(DC, SaveTextColor);
  DeleteObject(SelectObject(DC, SaveBrush));
  DeleteObject(Bitmap);
end;