oleinterface.pas

是一个delphi的流程制作软件

//--- Ole Interface Conversions ------------------------------------------------
//
// A set of conversion routines which take COM interfaces and provide
// Delphi styled abstract methods using the same name but different parameters.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}
{$O-}

unit OleInterface;

interface

uses
  Windows, SysUtils, Classes, ActiveX, Forms, OleDlg, OleConsts,
  ComCtrls, RichOle, RichEdit, OleErrors, OleStd;

// provides public access to _AddRef and _Release methods
type
  TInterfacedObject2 = class (TInterfacedObject)
  public
//    procedure BeforeDestruction; override;
    function AddRef : integer;
    function Release : integer;
  end;

// Provides a IUnknown Interface to a TComponent
  TInterfacedComponent = class (TComponent, IUnknown)
  private
    function _AddRef: integer; reintroduce; stdcall;
    function _Release: integer; reintroduce; stdcall;
  protected
    FRefCount : integer;
    function QueryInterface (const IID: TGUID; out Obj): HResult; reintroduce; stdcall;
  public
    procedure BeforeDestruction; override;
    function AddRef : integer;
    function Release : integer;
    property RefCount: integer read FRefCount;
  end;

// Provides a translation of a IDropTarget interface into Delphi
type
  TBaseDropTarget = class (TInterfacedComponent, IDropTarget)
// IDropTarget
    function DragEnter (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; overload; stdcall;
    function DragOver (grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; overload; stdcall;
    function DragLeave : HResult; overload; stdcall;
    function Drop (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult; overload; stdcall;
  private
    FDataObject : IDataObject;
  protected
    procedure DragEnter (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); overload; virtual; abstract;
    procedure DragOver (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); overload; virtual; abstract;
    procedure DragLeave (var Result : integer); overload; virtual; abstract;
    procedure Drop (DataObject : IDataObject; State : TShiftState; Pt : TPoint; var Effect, Result : integer); overload; virtual; abstract;
    property DataObject : IDataObject read FDataObject;
  end;

// This implements the IDropSource interface using two abstract methods (which
// must be overridden in descendant classes) to pass the calls onto the Delphi
// code using Delphi style variables and types.  Each member is overloaded so
// the names of the interface and abstract methods are the same.

  TBaseDropSource = class (TInterfacedComponent, IDropSource)
// IDropSource
    function QueryContinueDrag (fEscapePressed: BOOL; grfKeyState: Longint): HResult; overload; stdcall;
    function GiveFeedback (dwEffect: Longint): HResult; overload; stdcall;
  protected
    procedure QueryContinueDrag (EscapePressed : boolean; KeyState : TShiftState; var Result : integer); overload; virtual; abstract;
    procedure GiveFeedback (Effect : integer; var Result : integer); overload; virtual; abstract;
  end;

// This implements an IDataObject in the same way, based on a component
  TBaseDataObject = class (TInterfacedComponent, IDataObject)
// IDataObject
    function GetData (const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; overload; stdcall;
    function GetDataHere (const formatetc: TFormatEtc; out medium: TStgMedium): HResult; overload; stdcall;
    function QueryGetData (const formatetc: TFormatEtc): HResult; overload; stdcall;
    function GetCanonicalFormatEtc (const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; overload; stdcall;
    function SetData (const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; overload; stdcall;
    function EnumFormatEtc (dwDirection: Longint; out enumFormatEtc_: IEnumFormatEtc): HResult; overload; stdcall;
    function DAdvise (const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; overload; stdcall;
    function DUnadvise (dwConnection: Longint): HResult; overload; stdcall;
    function EnumDAdvise (out enumAdvise: IEnumStatData): HResult; overload; stdcall;
  protected
    procedure GetData (const FormatEtc : TFormatEtc; var Medium : TStgMedium; var Result : integer); overload; virtual; abstract;
    procedure GetDataHere (const FormatEtc: TFormatEtc; var Medium: TStgMedium; var Result : integer); overload; virtual; abstract;
    procedure QueryGetData (const FormatEtc: TFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure GetCanonicalFormatEtc (const FormatEtcIn: TFormatEtc; var FormatEtcOut: TFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure SetData (const formatetc: TFormatEtc; var Medium: TStgMedium; Release: boolean; var Result : integer); overload; virtual; abstract;
    procedure EnumFormatEtc (Direction: integer; var EnumFormatEtc: IEnumFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure DAdvise (const FormatEtc: TFormatEtc; Advf: integer; const AdvSink: IAdviseSink; var Connection: integer; var Result : integer); overload; virtual; abstract;
    procedure DUnadvise (Connection: integer; var Result : integer); overload; virtual; abstract;
    procedure EnumDAdvise (var EnumAdvise: IEnumStatData; var Result : integer); overload; virtual; abstract;
  end;

// This is based on an object
  TObjectBaseDataObject = class (TInterfacedObject2, IDataObject)
    function GetData (const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; overload; stdcall;
    function GetDataHere (const formatetc: TFormatEtc; out medium: TStgMedium): HResult; overload; stdcall;
    function QueryGetData (const formatetc: TFormatEtc): HResult; overload; stdcall;
    function GetCanonicalFormatEtc (const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; overload; stdcall;
    function SetData (const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; overload; stdcall;
    function EnumFormatEtc (dwDirection: Longint; out enumFormatEtc_: IEnumFormatEtc): HResult; overload; stdcall;
    function DAdvise (const formatetc: TFormatEtc; advf: Longint; const advSink: IAdviseSink; out dwConnection: Longint): HResult; overload; stdcall;
    function DUnadvise (dwConnection: Longint): HResult; overload; stdcall;
    function EnumDAdvise (out enumAdvise: IEnumStatData): HResult; overload; stdcall;
  protected
    procedure GetData (const FormatEtc : TFormatEtc; var Medium : TStgMedium; var Result : integer); overload; virtual; abstract;
    procedure GetDataHere (const FormatEtc: TFormatEtc; var Medium: TStgMedium; var Result : integer); overload; virtual; abstract;
    procedure QueryGetData (const FormatEtc: TFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure GetCanonicalFormatEtc (const FormatEtcIn: TFormatEtc; var FormatEtcOut: TFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure SetData (const formatetc: TFormatEtc; var Medium: TStgMedium; Release: boolean; var Result : integer); overload; virtual; abstract;
    procedure EnumFormatEtc (Direction: integer; var EnumFormatEtc: IEnumFormatEtc; var Result : integer); overload; virtual; abstract;
    procedure DAdvise (const FormatEtc: TFormatEtc; Advf: integer; const AdvSink: IAdviseSink; var Connection: integer; var Result : integer); overload; virtual; abstract;
    procedure DUnadvise (Connection: integer; var Result : integer); overload; virtual; abstract;
    procedure EnumDAdvise (var EnumAdvise: IEnumStatData; var Result : integer); overload; virtual; abstract;
  end;

// This implements an IEnumFormatEtc in the same way
  TBaseEnumFormatEtc = class (TInterfacedObject2, IEnumFORMATETC)
    function Next (celt: Longint; out elt; pceltFetched: PLongint): HResult; overload; stdcall;
    function Skip (celt: Longint): HResult; overload; stdcall;
    function Reset : HResult; overload; stdcall;
    function Clone (out Enum: IEnumFormatEtc): HResult; overload; stdcall;
  protected
    procedure Next (Celt : integer; var FormatEtc : TFormatEtc; var Fetched : integer; var Result : integer); overload; virtual; abstract;
    procedure Skip (Celt : integer; var Result : integer); overload; virtual; abstract;
    procedure Reset (var Result : integer); overload; virtual; abstract;
    procedure Clone (var Enum : IEnumFormatEtc; var Result : integer); overload; virtual; abstract;
  end;

// This implements an IAdviseSink in the same way.  But note the bodge to get
// the second overloaded class to have the same name - the introduction of a
// dummy Result parameter - does nothing (sorry).
  TBaseAdviseSink = class (TInterfacedObject2, IAdviseSink)
    procedure OnDataChange (const formatetc: TFormatEtc; const stgmed: TStgMedium); overload; stdcall;
    procedure OnViewChange (dwAspect : longint; lindex : longint); overload;  stdcall;
    procedure OnRename (const mk: IMoniker); overload; stdcall;
    procedure OnSave; overload; stdcall;
    procedure OnClose; overload; stdcall;
  protected
    procedure OnDataChange (const FormatEtc: TFormatEtc; const Medium : TStgMedium; var Result : integer); overload; virtual; abstract;
    procedure OnViewChange (Aspect, Index: integer; var Result : integer); overload; virtual; abstract;
    procedure OnRename (const Moniker: IMoniker; var Result : integer); overload; virtual; abstract;
    procedure OnSave (var Result : integer); overload; virtual; abstract;
    procedure OnClose (var Result : integer); overload; virtual; abstract;
  end;

// This implements an IMessageFilter in the same way
// ctNull and ptNull ensure enumeration starts at 1
  TCallType    = (ctNull, ctTopLevel, ctNested, ctASync, ctTopLevelPending, ctASyncPending);
  TServerCall  = (scIsHandled, scRejected, scRetryLater);
  TPendingType = (ptNull, ptTopLevel, ptNested);
  TPendingMsg  = (pmCancel, pmWaitNoProcess, pmWaitDefProcess);
  TBaseMessageFilter = class (TComponent, IMessageFilter)
    function HandleInComingCall(dwCallType: Longint; htaskCaller: HTask; dwTickCount: Longint; lpInterfaceInfo: PInterfaceInfo): Longint; overload; stdcall;
    function RetryRejectedCall(htaskCallee: HTask; dwTickCount: Longint; dwRejectType: Longint): Longint; overload; stdcall;
    function MessagePending(htaskCallee: HTask; dwTickCount: Longint; dwPendingType: Longint): Longint; overload; stdcall;
  protected
    procedure HandleInComingCall (CallType : TCallType; Task : hTask; TickCount : integer; var Info : TInterfaceInfo; var Result : TServerCall); overload; virtual; abstract;
    procedure RetryRejectedCall (Task : hTask; TickCount : integer; Reject : TServerCall; var Result : integer); overload; virtual; abstract;
    procedure MessagePending (Task : hTask; TickCount : integer; Pending : TPendingType; var Result : TPendingMsg); overload; virtual; abstract;
  end;

//=== Callback interface for RichEdit Ole functions ============================

  TREFlag = (rePaste, reDrop, reCopy, reCut, reDrag);  // see RECO_XXXXX flags in RichOle, do nor re-order

  TBaseREOleCallback = class (TInterfacedObject2, IRichEditOleCallback)
    function GetNewStorage (out stg: IStorage): HRESULT; overload; stdcall;
    function GetInPlaceContext (out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo): HRESULT; overload; stdcall;
    function ShowContainerUI (fShow: BOOL): HRESULT; overload; stdcall;
    function QueryInsertObject (const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT; overload; stdcall;
    function DeleteObject (oleobj: IOLEObject): HRESULT; overload; stdcall;
    function QueryAcceptData (dataobj: IDataObject; var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT; overload; stdcall;
    function ContextSensitiveHelp (fEnterMode: BOOL): HRESULT; overload; stdcall;
    function GetClipboardData (const chrg: TCharRange; reco: DWORD; out dataobj: IDataObject): HRESULT; overload; stdcall;
    function GetDragDropEffect (fDrag: BOOL; grfKeyState: DWORD; var dwEffect: DWORD): HRESULT; overload; stdcall;
    function GetContextMenu (seltype: Word; oleobj: IOleObject; const chrg: TCharRange; var menu: HMENU): HRESULT; overload; stdcall;
  protected
    procedure GetNewStorage (var Stg: IStorage; var Result : integer); overload; virtual; abstract;
    procedure GetInPlaceContext (var Frame: IOleInPlaceFrame; var Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo; var Result : integer); overload; virtual; abstract;
    procedure ShowContainerUI (Show : boolean; var Result : integer); overload; virtual; abstract;
    procedure QueryInsertObject (const CLSID: TCLSID; Stg: IStorage; Cp: integer; var Result : integer); overload; virtual; abstract;
    procedure DeleteObject (OleObject: IOLEObject; var Result : integer); overload; virtual; abstract;
    procedure QueryAcceptData (DataObject: IDataObject; var Format: TClipFormat; Reco:  TREFlag; Really: boolean; MetaPict: hGlobal; var Result : integer); overload; virtual; abstract;
    procedure ContextSensitiveHelp (EnterMode: boolean; var Result : integer); overload; virtual; abstract;
    procedure GetClipboardData (const CharRange : TCharRange; Reco : TREFlag; var DataObject: IDataObject; var Result : integer); overload; virtual; abstract;
    procedure GetDragDropEffect (Drag: boolean; ShiftState : TShiftState; var Effect: integer; var Result : integer); overload; virtual; abstract;
    procedure GetContextMenu (SelType : word; OleObject : IOleObject; const CharRange: TCharRange; var Menu: hMenu; var Result : integer); overload; virtual; abstract;
  end;

// use this procedure to set the callback interface
procedure REOleSetCallback (RichEdit : TCustomRichEdit; OleInterface: IRichEditOleCallback);

// This is the Rich Edit caller class, used to translate Delphi to Ole and C stuff
// Also raises exceptions on error rather than return an error code.
type
  TRichEditOle = class
  private
    FRichEditOle : IRichEditOle;
  public
    constructor Create (ARichEdit : TCustomRichEdit);
    function  GetClientSite : IOleClientSite;
    function  GetObjectCount : integer;
    function  GetLinkCount : integer;
    function  GetObject (Index : integer = 0; Flags : TREObjectFlags = [reSelection]) : TREObject;
    procedure InsertObject (REObject : TREObject);
    procedure ConvertObject (Obj : integer; NewCLSID : TCLSID; UserTypeNew : string);
    procedure ActivateAs (CLSID, CLSIDAs : TCLSID);
    procedure SetHostNames (ContainerApp, ContainerObj : string);
    procedure SetLinkAvailable (Obj : integer; Available : boolean);
    procedure SetDvaspect (Obj : integer; dvAspect : DWORD);
    procedure HandsOffStorage (Obj : integer);
    procedure SaveCompleted (Obj : integer; Stg : IStorage);
    procedure InPlaceDeactivate;
    procedure ContextSensitiveHelp (EnterMode : boolean);
    function  GetClipboardData (Chrg : TCharRange; Reco : TREFlag) : IDataObject;
    procedure ImportDataObject (DataObj : IDataObject; Format : TClipFormat; MetaPict : hGlobal);
  end;

//=== Used by various OLE UI Dialogs ===========================================

type
  TBaseOleObjInfo = class (TInterfacedObject2, IOleUIObjInfo)
    function GetObjectInfo (dwObject: Longint; var dwObjSize: Longint; var lpszLabel: PChar; var lpszType: PChar; var lpszShortType: PChar; var lpszLocation: PChar): HResult; overload; stdcall;
    function GetConvertInfo (dwObject: Longint; var ClassID: TCLSID; var wFormat: Word; var ConvertDefaultClassID: TCLSID; var lpClsidExclude: PCLSID; var cClsidExclude: Longint): HResult; overload; stdcall;
    function ConvertObject (dwObject: Longint; const clsidNew: TCLSID): HResult; overload; stdcall;
    function GetViewInfo (dwObject: Longint; var hMetaPict: HGlobal;  var dvAspect: Longint; var nCurrentScale: Integer): HResult; overload; stdcall;
    function SetViewInfo (dwObject: Longint; hMetaPict: HGlobal; dvAspect: Longint; nCurrentScale: Integer; bRelativeToOrig: BOOL): HResult; overload; stdcall;
  protected
    procedure GetObjectInfo (ObjectId: integer; var ObjectSize: integer; var ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation: string; var Result : integer); overload; virtual; abstract;
    procedure GetConvertInfo (ObjectId: integer; var ClassID: TCLSID; var Format: TClipFormat; var ConvertDefaultClassID: TCLSID; var ClsidExclude: PCLSID; var ClsidExcludeCount: integer; var Result : integer); overload; virtual; abstract;
    procedure ConvertObject (ObjectId: integer; const clsidNew: TCLSID; var Result : integer); overload; virtual; abstract;
    procedure GetViewInfo (ObjectId: integer; var MetaPict: hGlobal; var Aspect, CurrentScale: integer; var Result : integer); overload; virtual; abstract;
    procedure SetViewInfo (ObjectId: integer; MetaPict: hGlobal; Aspect, CurrentScale : integer; RelativeToOrig: boolean; var Result : integer); overload; virtual; abstract;
  end;

type
  TBaseOleLinkContainer = class (TInterfacedObject2, IOleUILinkContainer)
    function GetNextLink(dwLink: Longint): Longint; overload; stdcall;
    function SetLinkUpdateOptions(dwLink: Longint; dwUpdateOpt: Longint): HResult; overload; stdcall;
    function GetLinkUpdateOptions(dwLink: Longint; var dwUpdateOpt: Longint): HResult; overload; stdcall;
    function SetLinkSource(dwLink: Longint; pszDisplayName: PChar; lenFileName: Longint; var chEaten: Longint; fValidateSource: BOOL): HResult; overload; stdcall;
    function GetLinkSource(dwLink: Longint; var pszDisplayName: PChar; var lenFileName: Longint; var pszFullLinkType: PChar; var pszShortLinkType: PChar; var fSourceAvailable: BOOL; var fIsSelected: BOOL): HResult; overload; stdcall;
    function OpenLinkSource(dwLink: Longint): HResult; overload; stdcall;
    function UpdateLink(dwLink: Longint; fErrorMessage: BOOL; fErrorAction: BOOL): HResult; overload; stdcall;
    function CancelLink(dwLink: Longint): HResult; overload; stdcall;

  protected
    procedure GetNextLink (LinkId: integer; var Result : integer); overload; virtual; abstract;
    procedure SetLinkUpdateOptions (LinkId, UpdateOpt : integer; var Result : integer); overload; virtual; abstract;
    procedure GetLinkUpdateOptions (LinkId: integer; var UpdateOpt, Result : integer); overload; virtual; abstract;
    procedure SetLinkSource (LinkId: integer; DisplayName: string; var NameLen : integer; var Eaten: integer; ValidateSource: boolean; var Result : integer); overload; virtual; abstract;
    procedure GetLinkSource (LinkId: integer; var DisplayName, FullLinkType, ShortLinkType : string; var Filename : integer; var SourceAvailable, IsSelected : boolean; var Result : integer); overload; virtual; abstract;
    procedure OpenLinkSource (LinkId: integer; var Result : integer); overload; virtual; abstract;
    procedure UpdateLink (LinkId: integer; ErrorMessage, ErrorAction: boolean; var Result : integer); overload; virtual; abstract;
    procedure CancelLink (LinkId: integer; var Result : integer); overload; virtual; abstract;
  end;

  TBaseOleLinkInfo = class (TBaseOleLinkContainer, IOleUILinkInfo)
    function GetLastUpdate(dwLink: Longint; var LastUpdate: TFileTime): HResult; overload; stdcall;
  protected
    procedure GetLastUpdate (LinkId : integer; var LastUpdate: TFileTime; var Result : integer); overload; virtual; abstract;
  end;

function KeysToShiftState(Keys: Word): TShiftState;

//==============================================================================

implementation

// Original in Forms.pas
function KeysToShiftState(Keys: Word): TShiftState;
const
  MK_ALT = 32;
begin
  Result := [];
  if Keys and MK_SHIFT <> 0 then Include(Result, ssShift);
  if Keys and MK_CONTROL <> 0 then Include(Result, ssCtrl);
  if Keys and MK_LBUTTON <> 0 then Include(Result, ssLeft);
  if Keys and MK_RBUTTON <> 0 then Include(Result, ssRight);
  if Keys and MK_MBUTTON <> 0 then Include(Result, ssMiddle);
  if (Keys and MK_ALT <> 0) or (GetKeyState(VK_MENU) < 0) then Include(Result, ssAlt)
end;

//=== INTERFACED OBJECT 2 ======================================================

function TInterfacedObject2.AddRef : integer;
begin
  Result := _AddRef
end;

function TInterfacedObject2.Release : integer;
begin
  Result := _Release
end;

(*
// Handy for debugging
procedure TInterfacedObject2.BeforeDestruction;
begin
  inherited BeforeDestruction
end;
*)

//=== INTERFACED COMPONENT =====================================================

procedure TInterfacedComponent.BeforeDestruction;
begin
end;

function TInterfacedComponent.QueryInterface(const IID: TGUID; out Obj): HResult;
const
  E_NOINTERFACE = $80004002;
begin
  if GetInterface(IID, Obj) then
    Result := NOERROR
  else
    Result := integer(E_NOINTERFACE)
end;

function TInterfacedComponent._AddRef : integer;
begin
  Result := 0
end;

function TInterfacedComponent._Release: integer;
begin
  Result := 0
end;

function TInterfacedComponent.AddRef : integer;
begin
  Result := _AddRef
end;

function TInterfacedComponent.Release : integer;
begin
  Result := _Release
end;

//--- IDropTarget methods ---
// This is the actual drop target handler that Windows sees.  It calls the
// appropriate DoXxxxx methods in the Delphi wrapper component.

// When a dragged object is brought into the window this interface method is
// called.  By default the drop effect is set to none (no entry sign).  The
// DoDragEnter method of the component is called.
function TBaseDropTarget.DragEnter (const DataObj: IDataObject; grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
  Result := ddOk;
  try
    dwEffect := deNone;
    FDataObject := DataObj;
    DragEnter (DataObj, KeysToShiftState (grfKeyState), Pt, dwEffect, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

// This interface method is called repeatedly as the dragged object is moved around
// inside the drop target.
function TBaseDropTarget.DragOver (grfKeyState: Longint; pt: TPoint; var dwEffect: Longint): HResult;
begin
  Result := ddOk;
  try
    dwEffect := deNone;
    DragOver (FDataObject, KeysToShiftState (grfKeyState), Pt, dwEffect, integer(Result))
  except
    Result := ddUnexpected;
    raise
  end
end;

// This interface method is called if the dragged object leaves the drop target.
function TBaseDropTarget.DragLeave: HResult;
begin
  Result := ddOk;
  try
    try
      DragLeave (integer(Result))
    except
      Result := ddUnexpected;
      raise
    end
  finally