redemo1.pas

是一个delphi的流程制作软件

//--- Ole Rich Edit Extensions -------------------------------------------------
//
// Minimal extension to TRichEdit to allow drag and drop of objects.
//
// Freeware - you get it for nothing - I make no promises
//
// Grahame Marsh
//
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}


unit REDemo1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, RichEdit, RichOle, ActiveX, OleStd, OleConsts;

type
  TREOleCallBack = class (TInterfacedObject, 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;
  private
    FItemCount : integer;
    FStorage : IStorage;
  public
    constructor Create;
  end;

  TForm1 = class(TForm)
    RichEdit: TRichEdit;
    procedure FormCreate(Sender: TObject);
  private
    FOleInterface : TREOleCallback;
  public
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

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

constructor TREOleCallBack.Create;
begin
  inherited Create;
  FStorage := OleStdCreateTempRootStorage (StorageMode)
end;

function TREOleCallBack.GetNewStorage (out Stg: IStorage): HRESULT;
begin
  Result:= ddOk;
  inc (FItemCount);
  Stg := OleStdCreateChildStorage (FStorage, Format ('REOBJ%d', [FItemCount]), SubStorageMode)
end;

function TREOleCallBack.GetInPlaceContext (out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo): HRESULT;
begin
  Result:=  ddNotImplemented
end;

function TREOleCallBack.ShowContainerUI (fShow: BOOL): HRESULT;
begin
  Result:=  ddNotImplemented
end;

function TREOleCallBack.QueryInsertObject (const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT;
begin
  Result :=  ddOk
end;

function TREOleCallBack.DeleteObject (oleobj: IOLEObject): HRESULT;
begin
  Result :=  ddNotImplemented
end;

function TREOleCallBack.QueryAcceptData (dataobj: IDataObject; var cfFormat: TClipFormat; reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT;
begin
  Result := ddOk
end;

function TREOleCallBack.ContextSensitiveHelp (fEnterMode: BOOL): HRESULT;
begin
  Result :=  ddNotImplemented
end;

function TREOleCallBack.GetClipboardData (const chrg: TCharRange; reco: DWORD; out dataobj: IDataObject): HRESULT;
begin
  Result := ddNotImplemented
end;

function TREOleCallBack.GetDragDropEffect (fDrag: BOOL; grfKeyState: DWORD; var dwEffect: DWORD): HRESULT;
begin
  Result := ddNotImplemented
end;

function TREOleCallBack.GetContextMenu (seltype: Word; oleobj: IOleObject; const chrg: TCharRange; var menu: HMENU): HRESULT;
begin
  Result := ddNotImplemented
end;

procedure REOleSetCallback (RichEdit : TCustomRichEdit; OleInterface: IRichEditOleCallback);
begin
  if (not Assigned (RichEdit)) or (SendMessage (RichEdit.Handle, EM_SETOLECALLBACK, 0, integer (OleInterface)) = 0) then
    raise Exception.Create('Unable to set RichEditOleCallback')
end;

procedure TForm1.FormCreate (Sender: TObject);
begin
  FOleInterface := TREOleCallBack.Create;
  REOleSetCallback (Richedit, FOleInterface)
end;

end.