unit re_bmp;

 

interface

 

uses Windows;

 

procedure InsertBitmapToRE(Wnd:HWND; Bmp:HBITMAP);

 

implementation

 

uses Activex, RichEdit;

 

const

  IID_IDataObject: TGUID = (

   D1:$0000010E;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));

 

  REO_CP_SELECTION    = ULONG(-1);

  REO_IOB_SELECTION   = ULONG(-1);

  REO_GETOBJ_POLEOBJ  =  $00000001;

 

type

  TReobject = record

    cbStruct: DWORD;

    cp: ULONG;

    clsid: TCLSID;

    poleobj: IOleObject;

    pstg: IStorage;

    polesite: IOleClientSite;

    sizel: TSize;

    dvAspect: Longint;

    dwFlags: DWORD;

    dwUser: DWORD;

  end;

 

type

  IRichEditOle = interface(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;

 

  TImageDataObject=class(TInterfacedObject,IDataObject)

  private

   FBmp:HBITMAP;

   FMedium:TStgMedium;

   FFormatEtc: TFormatEtc;

   procedure SetBitmap(bmp:HBITMAP);

   function GetOleObject(OleClientSite:IOleClientSite; Storage:IStorage):IOleObject;

   destructor Destroy;override;

 

   // IDataObject

   function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;

    function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;

    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;

    function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall;

    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall;

    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;

    function DAdvise(const formatetc: TFormatEtc; advf: Longint;

                     const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;

    function DUnadvise(dwConnection: Longint): HResult; stdcall;

    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;

  public

   procedure InsertBitmap(wnd:HWND; Bitmap:HBITMAP);

  end;

 

 

{ TImageDataObject }

 

function TImageDataObject.DAdvise(const formatetc: TFormatEtc; advf: Integer;

  const advSink: IAdviseSink; out dwConnection: Integer): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.DUnadvise(dwConnection: Integer): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.EnumFormatEtc(dwDirection: Integer; out enumFormatEtc: IEnumFormatEtc): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

function TImageDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;

begin

 Result:=E_NOTIMPL;

end;

 

destructor TImageDataObject.Destroy;

begin

 ReleaseStgMedium(FMedium);

end;

 

function TImageDataObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;

begin

 medium.tymed := TYMED_GDI;

 medium.hBitmap :=  FMedium.hBitmap;

 medium.unkForRelease := nil;

 Result:=S_OK;

end;

 

function TImageDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;

begin

 FFormatEtc := formatetc;

 FMedium := medium;

 Result:= S_OK;

end;

 

procedure TImageDataObject.SetBitmap(bmp: HBITMAP);

var

 stgm: TStgMedium;

 fm:TFormatEtc;

begin

 stgm.tymed := TYMED_GDI;

 stgm.hBitmap := bmp;

 stgm.UnkForRelease := nil;

 

 fm.cfFormat := CF_BITMAP;

 fm.ptd := nil;

 fm.dwAspect := DVASPECT_CONTENT;

 fm.lindex := -1;

 fm.tymed := TYMED_GDI;

 SetData(fm, stgm, FALSE);

end;

 

function TImageDataObject.GetOleObject(OleClientSite: IOleClientSite; Storage: IStorage):IOleObject;

begin

 if (Fmedium.hBitmap=0) then Result:=nil else

  OleCreateStaticFromData(self, IID_IOleObject, OLERENDER_FORMAT, @FFormatEtc, OleClientSite, Storage, Result);

end;

 

procedure TImageDataObject.InsertBitmap(wnd:HWND; Bitmap: HBITMAP);

var

 OleClientSite:IOleClientSite;

 RichEditOLE:IRichEditOLE;

 Storage:IStorage;

 LockBytes:ILockBytes;

 OleObject:IOleObject;

 reobject:TReobject;

 clsid:TGUID;

begin

 if (SendMessage(wnd, EM_GETOLEINTERFACE, 0, cardinal(@RichEditOle))=0) then exit;

 

 FBmp:=CopyImage(Bitmap,IMAGE_BITMAP,0,0,0);

 if  FBmp=0 then exit;

 try

   SetBitmap(Fbmp);

   RichEditOle.GetClientSite(OleClientSite);

   if (OleClientSite=nil) then exit;

   CreateILockBytesOnHGlobal(0, TRUE,LockBytes);

   if (LockBytes = nil) then exit;

   if (StgCreateDocfileOnILockBytes(LockBytes, STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0,Storage)<> S_OK) then

   begin

      LockBytes._Release;

      exit

    end;

 

   if (Storage = nil) then exit;

   OleObject:=GetOleObject(OleClientSite, Storage);

   if (OleObject = nil) then exit;

   OleSetContainedObject(OleObject, TRUE);

 

   ZeroMemory(@reobject, sizeof(TReobject));

   reobject.cbStruct := sizeof(TReobject);

   OleObject.GetUserClassID(clsid);

   reobject.clsid := clsid;

   reobject.cp := REO_CP_SELECTION;

   reobject.dvaspect := DVASPECT_CONTENT;

   reobject.poleobj := OleObject;

   reobject.polesite := OleClientSite;

   reobject.pstg := Storage;

 

   RichEditOle.InsertObject(reobject);

 finally

   DeleteObject(FBmp)

 end

end;

 

 

procedure InsertBitmapToRE(Wnd:HWND; bmp:HBITMAP);

begin

 with TImageDataObject.Create do

 try

  InsertBitmap(Wnd,Bmp);

 finally

  Free

 end

end;

 

 

end.

uses re_bmp;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

 InsertBitmapToRE(RichEdit1.Handle,Image1.Picture.Bitmap.Handle);

end;

 

...

 

procedure TForm1.Button2Click(Sender: TObject);

var

 bmp:TBitmap;

begin

 if (not OpenPictureDialog1.Execute) then exit;

 bmp:=TBitmap.Create;

 try

   bmp.LoadFromFile(OpenPictureDialog1.Filename);

   InsertBitmapToRE(RichEdit1.Handle,bmp.Handle);

 finally

   bmp.Free

 end

end;