olere.pas

是一个delphi的流程制作软件

//--- Ole Rich Edit Extensions -------------------------------------------------
//
// A non-visual extension component for a TRichEdit control that brings in Ole
// drag and drop of objects.  Links to all of the Ole UI Dialogs.
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}

unit OleRE;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, RichEdit, RichOle, ActiveX, OleDlg, ComObj,

  OleDnD, OleForm, OleErrors, OleConsts, OleDlgs, OleInterface, OleLinks,
  OleStd, OleHelpers;

type
  TContextHelpCallBack = procedure (Sender : TObject; EnterMode : boolean; var Result : integer) of object;
  TDeleteObjectCallBack = procedure (Sender : TObject; OleObject : IOleObject) of object;
  TClipboardCallBack = procedure (Sender : TObject; Chrg : TCharRange; Reco : TREFlag; DataObject : IDataObject; var Result : integer) of object;
  TContextMenuCallBack = procedure (Sender : TObject; SelType : word; OleObject : IOleObject; Chrg : TCharRange; Menu : hMenu; var Result : integer) of object;
  TDragDropEffectCallBack = procedure (Sender : TObject; Drag : boolean; State : TShiftState; var Effect : integer) of object;
  TNewStorageCallBack = procedure (Sender : TObject; var Storage : IStorage; var Result : integer) of object;
  TQueryAcceptDataCallBack = procedure (Sender : TObject; DataObject : IDataObject; Format : TClipFormat; Reco : TREFlag; Really : boolean; Meta : hGlobal; var Result : integer) of object;
  TQueryInsertObjectCallback = procedure (Sender : TObject; CLSID : TCLSID; Storage : IStorage; Cp : integer; var Result : integer) of object;
  TShowContainerCallBack = procedure (Sender : TObject; Show : boolean; var Result : integer) of object;

  TOleRE = class (TComponent)
  private
// Holds reference to richedit control
    FRichEdit : TCustomRichEdit;
// Ole links to richedit control
    FRichEditOle : TRichEditOle;
    FRichEditOleCallback : IRichEditOleCallback;
// root storage to hold ole objects
    FStorage : IStorage;
// auto incrementing counter to give each substorage a unique name
    FItemCount : integer;
// Holds current save/load filter type
    FFilterIndex : integer;
// VCL Frame and Form interfaces
    FDoc,
    FFrame : IVCLFrameForm;
// Current save/load filename, and derived title
    FFilename,
    FTitle : string;
// Holds type of selected object marker
    FSelIndex : integer;
// Defines what detail is required using TREObject record
    FSelFlags : TREObjectFlags;
// Dialog links
    FInsertObject : TOleInsertObjectDialog;
    FObjectProps : TOleObjectPropsDialog;
    FEditLinks : TOleEditLinksDialog;
    FUpdateLinks : TOleUpdateLinksDialog;
    FPromptUser : TOlePromptUserDialog;
    FPasteSpecial : TOlePasteSpecialDialog;
    FChangeIcon : TOleChangeIconDialog;
    FChangeSource : TOleChangeSourceDialog;
    FConvertDialog : TOleConvertDialog;
// Events
    FContextHelp : TContextHelpCallBack;
    FDeleteObject : TDeleteObjectCallBack;
    FClipboard : TClipboardCallBack;
    FContextMenu : TContextMenuCallBack;
    FDragDropEffect : TDragDropEffectCallBack;
    FNewStorage : TNewStorageCallBack;
    FQueryAcceptData : TQueryAcceptDataCallBack;
    FQueryInsertObject : TQueryInsertObjectCallBack;
    FShowContainer : TShowContainerCallBack;

    procedure ConvertInfo (Wanted : TConvertInfos; var CLSID : TCLSID; var Format : TClipFormat; var TypeStr, LabelStr : string; var Metafile : hGlobal);
    procedure CreateObjectFromInfo (const CreateInfo: TCreateInfo);
    function GetAspect : integer;
    function GetCanConvertOrActivateAs : boolean;
    function GetCanPaste: boolean;
    function GetCanRevert : boolean;
    function GetClientSite : IOleClientSite;
    function GetCLSID : TCLSID;
    function GetFullName : string;
    function GetIconic: Boolean;
    function GetIconMetaPict: HGlobal;
    function GetLinkCount : integer;
    function GetLinked: Boolean;
    function GetMoniker : IMoniker;
    function GetMonikerDisplayName : string;
    function GetObjectCount : integer;
    function GetObjectDataSize : integer;
    function GetObject (Index : integer; Flags : TREObjectFlags) : TREObject;
    function GetObjectSite : IOleClientSite;
    function GetObjectStorage : IStorage;
    function GetObjectVerbs: TStringList;
    function GetProgID: string;
    function GetOleObject: Variant;
    function GetPrimaryVerb: Integer;
    function GetSelected : IOleObject;
    function GetShortName : string;
    function GetSourceDoc: string;
    function GetState: TObjectState;
    function GetViewSize : TPoint;
    procedure SetRichEdit (RichEdit : TCustomRichEdit);
  protected
// Surface the IRichEditOle.XXX methods
    function GetClipboardData (Chrg : TCharRange; reco : TREFlag) : IDataObject;
    procedure HandsOffStorage;
    procedure ImportDataObject (DataObj : IDataObject; Format : TClipFormat; MetaPict : hGlobal);
    procedure InPlaceDeactivate;
    procedure Insert (REObject : TREObject);
    procedure SaveCompleted (Storage : IStorage = nil);
    procedure SetDrawAspect(Aspect : integer); overload;
    procedure SetLinkAvailable (Available : boolean);
// overridden component notifiction
    procedure Notification (AComponent: TComponent; Operation: TOperation); override;
// calls IRichEditOle.SetDrawAspect based on differing parameters, and controls
// the cached renders
    procedure SetDrawAspect(Iconic, Force: boolean; IconMetaPict: hGlobal); overload;
  public
    constructor Create (AOwner : TComponent); override;
    destructor Destroy; override;
// Need to call this when RichEdit control is being shut down.... manual ?
    procedure FreeInterfaces;

// These activate the various UI Dialogs
    function ChangeIconDialog: boolean;
    function ChangeSourceDialog : boolean;
    function ConvertDialog : boolean;
    function EditLinksDialog : boolean;
    function EditLinkDialog : boolean;
    function InsertObjectDialog : boolean;
    function ObjectPropertiesDialog : boolean;
    function PasteSpecialDialog : boolean;
    procedure UpdateAllLinks;
    procedure UpdateLink;

// Causes an exception if no object is selected
    procedure CheckObject;
// Surface the IRichEditOle.ContextSensitiveHelp method
    procedure ContextSensitiveHelp (EnterMode : boolean);
// Execute the verb identfied by the selected object
    procedure DoVerb (Verb: Integer);
// Open this file (slightly more flexible than TRichEdit version)
    procedure Open (Filename : string; Fmt : integer; Insert : boolean);
// Revert object back to last save (see CanRevert)
    procedure Revert;
// Save current
    procedure Save;
// Save current into a new filename
    procedure SaveAs (const Filename : string; Selection : boolean);

    // The following properties are available when a selection flag
// and index value are set here:
    property SelFlags : TREObjectFlags read FSelFlags write FSelFlags;
    property SelIndex : integer read FSelIndex write FSelIndex;
// the display aspect of the selection
    property Aspect : integer read GetAspect;
// true if the current object can be converted or activatedas
    property CanConvertOrActivateAs : boolean read GetCanConvertOrActivateAs;
// returns the IOleClientSite interface for the object
    property ClientSite : IOleClientSite read GetObjectSite;
// returns CLSID of current object
    property CLSID : TCLSID read GetCLSID;
// returns size in bytes of the current object's storage
    property DataSize : integer read GetObjectDataSize;
// returns the full name of an object
    property FullName : string read GetFullName;
// true if the current object is an icon
    property Iconic : boolean read GetIconic;
// returns a global handle to a metafile icon
    property IconMetaPict : hGlobal read GetIconMetaPict;
// returns true if the current object is linked
    property Linked : boolean read GetLinked;
// returns the name of a linked object's source
    property LinkSource: string read GetSourceDoc;
// returns the IMoniker interface to the current object
    property Moniker : IMoniker read GetMoniker;
// returns the display name of the current object's moniker
    property MonikerDislayName : string read GetMonikerDisplayName;
// returns the IStorage interface for the object
    property Storage : IStorage read GetObjectStorage;
// returns the ole private name of the bject
    property ProgID: string read GetProgID;
// default action for the selected object
    property PrimaryVerb: Integer read GetPrimaryVerb;
// returns the IOleObject interface of the selected object
    property Selected : IOleObject read GetSelected;
// returns the ole short name
    property ShortName : string  read GetShortName;
// returns the status flag of the selected object
    property State: TObjectState read GetState;
// returns a string list of the verbs known by the object
    property Verbs: TStringList read GetObjectVerbs;
// retuns the size of the current selected
    property ViewSize : TPoint read GetViewSize;

// Returns the OleObject
    property AsVariant : Variant read GetOleObject;
// Returns true if the clipboard can be pasted
    property CanPaste: boolean read GetCanPaste;
// Returns true if a call to revert will work
    property CanRevert : boolean read GetCanRevert;
// Returns the IStorage interface of a selected object
    property StorageItem : integer read FItemCount;
// Returns the the IOleClientSite interface
    property MainSite : IOleClientSite read GetClientSite;
// Returns the the root IStorage interface
    property MainStorage : IStorage read FStorage;
// Returns number of objects in the
    property Count : integer read GetObjectCount;
// Current save filename
    property Filename : string read FFilename;
// Index of current filter
    property FilterIndex : integer read FFilterIndex;
// Returns the number of objects that are linked
    property Links : integer read GetLinkCount;
// Returns a TREObject for the given selection and contents set by Flags
    property REObject [Index : integer; Flags : TREObjectFlags] : TREObject read GetObject;

  published
// Linked to control
    property RichEdit : TCustomRichEdit read FRichEdit write SetRichEdit;
// dialog link properties
    property ChangeIcon : TOleChangeIconDialog read FChangeIcon write FChangeIcon;
    property ChangeSource : TOleChangeSourceDialog read FChangeSource write FChangeSource;
    property Convert : TOleConvertDialog read FConvertDialog write FConvertDialog;
    property EditLinks : TOleEditLinksDialog read FEditLinks write FEditLinks;
    property InsertObject : TOleInsertObjectDialog read FInsertObject write FInsertObject;
    property ObjectProps : TOleObjectPropsDialog read FObjectProps write FObjectProps;
    property PasteSpecial : TOlePasteSpecialDialog read FPasteSpecial write FPasteSpecial;
    property PromptUser : TOlePromptUserDialog read FPromptUser write FPromptUser;
    property UpdateLinks : TOleUpdateLinksDialog read FUpdateLinks write FUpdateLinks;
// callback events
    property OnContextHelp : TContextHelpCallBack read FContextHelp write FContextHelp;
    property OnDeleteObject : TDeleteObjectCallBack read FDeleteObject write FDeleteObject;
    property OnClipboard : TClipboardCallBack read FClipboard write FClipboard;
    property OnContextMenu : TContextMenuCallBack read FContextMenu write FContextMenu;
    property OnDragDropEffect : TDragDropEffectCallBack read FDragDropEffect write FDragDropEffect;
    property OnNewStorage : TNewStorageCallBack read FNewStorage write FNewStorage;
    property OnQueryAcceptData : TQueryAcceptDataCallBack read FQueryAcceptData write FQueryAcceptData;
    property OnQueryInsertObject : TQueryInsertObjectCallBack read FQueryInsertObject write FQueryInsertObject;
    property OnShowContainer : TShowContainerCallBack read FShowContainer write FShowContainer;
  end;

implementation

const
  StorageMode = fmOpenReadWrite or fmDeleteOnRelease or fmShareExclusive or fmTransacted;
  SubStorageMode = fmOpenReadWrite or fmShareExclusive or fmTransacted;

// Cop out
procedure LinkError(const Ident: string);
begin
  Application.MessageBox(PChar(Ident), PChar('Link Properties'), MB_OK or MB_ICONSTOP)
end;

//=== OLE UI Link Container ====================================================

type
  TOleUILinkContainer = class (TStdOleLinkContainer)
    procedure GetNextLink (LinkId: integer; var Result : integer); override;
    procedure OpenLinkSource (LinkId: integer; var Result : integer); override;
    procedure CancelLink (LinkId: integer; var Result : integer); override;
  private
    FOleRE : TOleRE;
    FLinkIndex : integer;
  public
    constructor Create (OleRE : TOleRE);
  end;

constructor TOleUILinkContainer.Create (OleRE : TOleRE);
begin
  inherited Create;
  FOleRE :=OleRE
end;

procedure TOleUILinkContainer.GetNextLink (LinkId: integer; var Result : integer);
var
  Next : boolean;
  REObject : TREObject;
  OleLink : IOleLink;
  OleObject : IOleObject;
begin
  Result := 0;
  if LinkId = 0 then
  begin
    FLinkIndex := 0;
    Next := true
  end else
    Next := false;
  repeat
    REObject := FOleRE.FRichEditOle.GetObject (FLinkIndex, [reIndex, reOleObject, reSite]);
    OleObject := REObject.OleObj;
    if not Assigned (OleObject) then
      exit;
    OleObject.QueryInterface (IOleLink, OleLink);
    if Assigned (OleLink) then
    begin
      if Next then
      begin
        Result := integer (OleLink);
        exit
      end;
      Next := LinkId = integer (OleLink)
    end;
    inc (FLinkIndex)
  until false
end;

procedure TOleUILinkContainer.OpenLinkSource (LinkId: integer; var Result : integer);
begin
  try
    FOleRE.DoVerb(ovShow)
  except
    Application.HandleException(FOleRE)
  end;
  Result := ddOk
end;

procedure TOleUILinkContainer.CancelLink (LinkId: integer; var Result : integer);
begin
  LinkError ('Cannot break link')
end;

// Special version of OleUILinkContainer that only contains the selected linked object
// Used with UpdateLink Procedure
type
  TOleUILinkContainer1 = class (TStdOleLinkContainer)
    procedure GetNextLink (LinkId: integer; var Result : integer); override;
  private
    FOleLink : IOleLink;
  public
    constructor Create (OleLink : IOleLink);
  end;

constructor TOleUILinkContainer1.Create (OleLink : IOleLink);
begin
  inherited Create;
  FOleLink := OleLink
end;

procedure TOleUILinkContainer1.GetNextLink (LinkId: integer; var Result : integer);
begin
  if LinkId = 0 then
    Result := integer (FOleLink)
  else
    Result := 0
end;

//=== OLE UI Object Information ------------------------------------------------

type
  TOleUIObjInfo = class (TBaseOleObjInfo)
  private
    FOleRE : TOleRE;
  protected
    procedure GetObjectInfo (ObjectId: integer; var ObjectSize: integer; var ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation: string; var Result : integer); override;
    procedure GetConvertInfo (ObjectId: integer; var ClassID: TCLSID; var Format: TClipFormat; var ConvertDefaultClassID: TCLSID; var ClsidExclude: PCLSID; var ClsidExcludeCount: integer; var Result : integer); override;
    procedure ConvertObject (ObjectId: integer; const clsidNew: TCLSID; var Result : integer); override;
    procedure GetViewInfo (ObjectId: integer; var MetaPict: hGlobal; var Aspect, CurrentScale: integer; var Result : integer); override;
    procedure SetViewInfo (ObjectId: integer; MetaPict: hGlobal; Aspect, CurrentScale : integer; RelativeToOrig: boolean; var Result : integer); override;
  public
    constructor Create (OleRE : TOleRE);
  end;

constructor TOleUIObjInfo.Create (OleRE : TOleRE);
begin
  inherited Create;
  FOleRE := OleRE
end;

procedure TOleUIObjInfo.GetObjectInfo (ObjectId: integer; var ObjectSize: integer; var ObjectLabel, ObjectLongType, ObjectShortType, ObjectLocation : string; var Result : integer);
var
  OleObject : IOleObject;
begin
  Result := ddOk;
  OleObject := FOleRE.Selected;
  ObjectSize := FOleRE.GetObjectDataSize;
  ObjectLabel := OleStdFullNameStr (OleObject);
  ObjectLongType := OleStdFullNameStr (OleObject);
  ObjectShortType := OleStdShortNameStr (OleObject);
  if FOleRE.Linked then
    ObjectLocation := FOleRE.MonikerDislayName
  else
    ObjectLocation := FOleRE.FFilename
end;

procedure TOleUIObjInfo.GetConvertInfo (ObjectId: integer; var ClassID: TCLSID; var Format: TClipFormat; var ConvertDefaultClassID: TCLSID; var ClsidExclude: PCLSID; var ClsidExcludeCount: integer; var Result : integer);
var
  UserType,
  LabelStr : string;
  MetaPict : hGlobal;
begin
  Result := ddOk;
  FOleRE.ConvertInfo ([ciFormat], ClassId, Format, UserType, LabelStr, MetaPict)
end;

procedure TOleUIObjInfo.ConvertObject (ObjectId: integer; const clsidNew: TCLSID; var Result : integer);
var
  OleObject : IOleObject;
begin
  OleObject := FOleRE.Selected;
  Screen.Cursor := crHourglass;
  try
    FOleRE.FRichEditOle.ConvertObject (reoSelection, CLSIDNew, '');
    OleObject.Update;
    Result := ddOk
  finally
    Screen.Cursor := crDefault
  end
end;

procedure TOleUIObjInfo.GetViewInfo (ObjectId: integer; var MetaPict: hGlobal; var Aspect, CurrentScale: integer; var Result : integer);
begin
  MetaPict := FOleRE.GetIconMetaPict;
  Aspect := FOleRE.GetAspect;
  CurrentScale := 100;
  Result := ddOk
end;

procedure TOleUIObjInfo.SetViewInfo (ObjectId: integer; MetaPict: hGlobal; Aspect, CurrentScale : integer; RelativeToOrig: boolean; var Result : integer);
var