olerichedit.pas

絮语2007视频聊天软件源程序.仅供参考

unit OLERichEdit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ActiveX, StdCtrls, ComCtrls, ComObj, RichEdit,richole;

type
  TOLEEdit = class(TRichEdit)
  private
    { Private declarations }
    procedure WMDestroy(var Msg: TMessage); message WM_DESTROY;  {!!0.01 -- changed from WM_NCDESTROY}
  protected
    { Protected declarations }
    procedure CloseOLEObjects;                      {!!0.01 -- added method}
    procedure CreateWnd; override;

  public
    { Public declarations }
    FRichEditOle: IRichEditOLE;
    FRichEditOleCallback: IRichEditOleCallback;
    constructor Create(AOwner: TComponent); override;
    procedure Clear; override;                          {!!0.01 -- overriden to close objects}
    function Objectselected:Boolean;
    function GetObjectCounts:integer;
    function getpicfilename:string;
    procedure Insertpicture(files:string);overload;
    procedure Insertpicture(files,md5code:string);overload;
  published

  end;

  TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
  private
    FOwner: TOLEEdit;
  protected
    function GetNewStorage(out stg: IStorage): HRESULT; stdcall;
    function GetInPlaceContext(out Frame: IOleInPlaceFrame;
         out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo): HRESULT; stdcall;
    function ShowContainerUI(fShow: BOOL): HRESULT; stdcall;
    function QueryInsertObject(const clsid: TCLSID; stg: IStorage; cp: longint): HRESULT; stdcall;
    function DeleteObject(oleobj: IOLEObject): HRESULT; stdcall;
    function QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
         reco: DWORD; fReally: BOOL; hMetaPict: HGLOBAL): HRESULT; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
    function GetClipboardData(const chrg: TCharRange; reco: DWORD;
         out dataobj: IDataObject): HRESULT; stdcall;
    function GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
         var dwEffect: DWORD): HRESULT; stdcall;
    function GetContextMenu(seltype: Word; oleobj: IOleObject;
         const chrg: TCharRange; var menu: HMENU): HRESULT; stdcall;
  public
    constructor Create(AOwner: TOLEEdit);
  end;


 procedure Register;

implementation

//------------------------------------------------------------------------------
//  richeditole
//------------------------------------------------------------------------------
constructor TRichEditOleCallback.Create(AOwner: TOLEEdit);
begin
  inherited Create;
  FOwner:= AOwner;
end;

function TRichEditOleCallback.GetNewStorage(out stg: IStorage): HRESULT;
var LockBytes: ILockBytes;
begin
  Result:= S_OK;
  try
    OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
    OleCheck(StgCreateDocfileOnILockBytes(LockBytes, STGM_READWRITE
      or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, stg));
  except
    Result:= E_OUTOFMEMORY;
  end;
end;

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

function TRichEditOleCallback.ShowContainerUI(fShow: BOOL): HRESULT;
begin
  Result:= E_NOTIMPL;
end;

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

function TRichEditOleCallback.DeleteObject(oleobj: IOLEObject): HRESULT;
begin                                     {!!0.01}
  oleobj.Close(OLECLOSE_NOSAVE);                  {!!0.01}
  Result:= S_OK;
end;

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

function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: BOOL): HRESULT;
begin
  Result:= E_NOTIMPL;
end;

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

function TRichEditOleCallback.GetDragDropEffect(fDrag: BOOL; grfKeyState: DWORD;
         var dwEffect: DWORD): HRESULT;
begin
  Result:= E_NOTIMPL;
  dwEffect:=DROPEFFECT_NONE;
end;

function TRichEditOleCallback.GetContextMenu(seltype: Word; oleobj: IOleObject;
         const chrg: TCharRange; var menu: HMENU): HRESULT;
var mouse:tpoint; bool:boolean;
begin
Result:= E_NOTIMPL;
getcursorpos(mouse);
FOwner.onContextPopup(nil,mouse,bool);
FOwner.PopupMenu.Popup(mouse.x,mouse.y);
end;
//------------------------------------------------------------------------------
//  oleedit
//------------------------------------------------------------------------------
constructor TOLEEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRichEditOleCallback:= TRichEditOleCallback.Create(Self);
end;

procedure TOLEEdit.CreateWnd;
begin
  inherited CreateWnd;
  if not RichEdit_GetOleInterface(Handle, FRichEditOle) then
    raise Exception.Create('Unable to get interface');
  if not RichEdit_SetOleCallback(Handle, FRichEditOlecallback) then
    raise Exception.Create('Unable to set callback');
end;

//------------------------------------------------------------------------------
// 返回 所选是否OLE
//------------------------------------------------------------------------------
function TOLEEdit.ObjectSelected:Boolean;
var ReObject:TReObject;
begin
  ReObject.cbStruct:= sizeof(TReObject);
  result:=(FRichEditOle.GetObject(integer(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ) = S_OK) and
          Assigned(ReObject.oleobj);
end;

//------------------------------------------------------------------------------
// 返回 ole object 数量
//------------------------------------------------------------------------------
function TOleEdit.GetObjectCounts:integer;
begin
result:=FRichEditOle.GetObjectCount;
end;

procedure TOleEdit.CloseOLEObjects;                      {!!0.01 -- added method}
var i: integer;
    REObject: TREObject;
begin
  if not Assigned(FRichEditOle) then Exit;
  fillchar(REObject, sizeof(REObject), 0);
  REObject.cbStruct:= sizeof(REObject);
  for i:= 0 to Pred(FRichEditOle.GetObjectCount) do begin
    if FRichEditOle.GetObject(i, REObject, REO_GETOBJ_POLEOBJ) = S_OK then
      REObject.oleobj.Close(OLECLOSE_NOSAVE);
  end;
end;

//------------------------------------------------------------------------------
// 返回PIC文件名
//------------------------------------------------------------------------------
function TOLEEdit.getpicfilename:string;
var ReObject:TReObject;
    FGifAnimator:IGifAnimator;
begin
result:='';
ReObject.cbStruct:= sizeof(REObject);
if FRichEditOle.GetObject(integer(REO_IOB_SELECTION), ReObject, REO_GETOBJ_POLEOBJ) = S_OK then
    begin
    ReObject.oleobj.QueryInterface(IID_IUnknown,FGifAnimator);
    if assigned(FGifAnimator) then result:=FGifAnimator.GetFilePath;
    end;
end;

//------------------------------------------------------------------------------
// 插入 pic
//------------------------------------------------------------------------------
procedure TOLEEdit.Insertpicture(files:string);
begin
Insertpicture(files,'');
end;

procedure TOLEEdit.Insertpicture(files,md5code:string);
var
  fole:ioleobject;
  FStorage:ISTORAGE;
  FClientSite:IOleClientSite;
  ReObject:TReObject;
  clsid:TGuid;
  Fanimator:IGifAnimator;
begin
if not fileexists(files) then exit;

FRichEditOleCallback.GetNewStorage(FStorage);
FRichEditOle.GetClientSite(FClientSite);
Fanimator:=IUnknown(CreateComObject(CLASS_GifAnimator)) as IGifAnimator;
Fanimator.LoadFromFile(PWideChar(WideString(files)));
Fanimator.QueryInterface(IID_IOleObject,fole);
OleSetContainedObject(FOle,TRUE);

fillchar(REObject, sizeof(REObject), 0);
reobject.cbStruct := sizeof(REOBJECT);
FOle.GetUserClassID(clsid);
reobject.clsid := clsid;
reobject.cp := integer(REO_CP_SELECTION);
reobject.dvaspect := DVASPECT_CONTENT;
reobject.dwFlags := ULong(REO_STATIC) or ULong(REO_BELOWBASELINE) ;
reobject.dwUser := 0;
reobject.oleobj := FOle;
reobject.olesite := FClientSite;
reobject.stg := FStorage;
ReObject.sizel.cx:=0;
ReObject.sizel.cy:=0;
FRichEditOle.InsertObject(reobject);
end;

procedure TOLEEdit.WMDestroy(var Msg: TMessage); {!!0.01 -- changed from WM_NCDESTROY}
begin
  CloseOLEObjects;                                {!!0.01}
  FRichEditOle:= nil;
  inherited;
end;

procedure TOLEEdit.Clear;                           {!!0.01 -- overriden to close objects}
begin
  CloseOLEObjects;
  inherited Clear;
end;

procedure Register;
begin
  RegisterComponents('Crypto', [TOLEEdit]);
end;

initialization
  CoInitialize(nil);
finalization
  CoUnInitialize;
end.