RichEdit 中插入图象 (Delphi)

unit InsRich;

interface

uses
  SysUtils, Windows, Messages, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ActiveX, ComCtrls;

const
  REO_CP_SELECTION   = ULONG(-1);
  REO_BELOWBASELINE  = $00000002;
  REO_RESIZEABLE     = $00000001;
  REO_STATIC         = $40000000;
  EM_GETOLEINTERFACE = WM_USER + 60;

  IID_IUnknown: TGUID = (D1:$00000000;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  IID_IOleObject: TGUID = (D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

type
  _ReObject = record
    cbStruct: DWORD;
    cp: ULONG;
    clsid: TCLSID;
    pOleObj: IOleObject;
    pstg: IStorage;
    sizel: TSize;
    dvAspect: Longint;
    dwFlags: DWORD;
    dwUser: DWORD;
  end;
  TReObject = _ReObject;

  TCharRange = record
    cpMin: Integer;
    cpMax: Integer;
  end;

  TFormatRange = record
    hdc: Integer;
    hdcTarget: Integer;
    rectRegion: TRect;
    rectPage: TRect;
    chrg: TCharRange;
  end;

  IRichEditOle = interface(System.IUnknown)
    ['{00020d00-0000-0000-c000-000000000046}']
    function GetClientSite(out ClientSite: IOleClientSite): HResult; stdcall;
    function GetObjectCount: HResult; stdcall;
    function GetLinkCount: HResult; stdcall;
    function GetObject(iob: Longint; out ReObject: TReObject; dwFlags: DWORD): HResult; stdcall;
    function InsertObject(var ReObject: TReObject): HResult; stdcall;
    function ConvertObject(iob: Longint; rclsidNew: TIID; lpstrUserTypeNew: LPCSTR): HResult; stdcall;
    function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall;
    function SetHostNames(lpstrContainerApp: LPCSTR; lpstrContainerObj: LPCSTR): HResult; stdcall;
    function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall;
    function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall;
    function HandsOffStorage(iob: Longint): HResult; stdcall;
    function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall;
    function InPlaceDeactivate: HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    function GetClipboardData(var chrg: TCharRange; reco: DWORD; out dataObj: IDataObject): HResult; stdcall;
    function ImportDataObject(dataObj: IDataObject; cf: TClipFormat; hMetaPict: HGLOBAL): HResult; stdcall;
  end;

function InsertBitmap(Editor: TRichEdit; BmpFile: string): Boolean;

implementation

function InsertBitmap(Editor: TRichEdit; BmpFile: string): Boolean;
var
  FRTF: IRichEditOle;
  FOle: IOleObject;
  FormatEtc: tagFormatETC;
  FStorage: ISTORAGE;
  FClientSite: IOleClientSite;
  FLockBytes: ILockBytes;
  ReObject: TReObject;
  xt: TGUID;
  FTemp: IUnknown;
begin
  Result := False;  
  if not FileExists(BmpFile) then
    Exit;

  try
    SendMessage(Editor.Handle, em_GetOleInterFace, 0, Longint(@FRTF));
    if not Assigned(FRTF) then
      Exit;
    if CreateILockBytesOnHGlobal(0, true, FLockBytes) <> S_OK then
      Exit;
    if StgCreateDocfileOnILockBytes(FLockBytes, STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, FStorage) <> S_OK then
      Exit;
    FormatEtc.cfFormat := 0;
    FormatEtc.ptd := nil;
    FormatEtc.dwAspect := DVASPECT_CONTENT;
    FormatEtc.lindex := -1;
    FormatEtc.tymed := TYMED_NULL;
    FRTF.GetClientSite(FClientSite);
    //从文件中创建一个Ole对象
    if OleCreateFromFile(GUID_NULL, PWideChar(WideString(BmpFile)), IID_IUnknown, 0,@FormatEtc, FClientSite, FStorage,FOle) <> S_OK then
      Exit;
    FTemp := FOle;
    FTemp.QueryInterface(IID_IOleObject, FOle);
    OleSetContainedObject(FOle, true);
    ReObject.cbStruct:=SizeOf(TReObject);
    FOle.GetUserClassID(xt);
    ReObject.clsid := xt;
    ReObject.cp := ULONG(REO_CP_SELECTION);
    ReObject.dvaspect := DVASPECT_CONTENT;
    ReObject.dwFlags := ULONG(REO_STATIC) or ULONG(REO_BELOWBASELINE);
    ReObject.dwUser := 0;
    ReObject.pOleObj := FOle;
    ReObject.pOleSite := FClientSite;
    ReObject.pstg := FStorage;
    ReObject.sizel.cx := 0;
    ReObject.sizel.cy := 0;
    FRTF.InsertObject(ReObject);
  finally
    FRTF := nil;
    FOle := nil;
  end;

  Result := True;
end;

end.