Как вставить Bitmap в TRichEdit?

=== Как вставить Bitmap в TRichEdit? ===
Вот так можно вставить картинку в формате Bitmap в позицию курсора в TRichEdit:
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
 Resul t:= 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;
Таким же образом можно вставлять картинки не только в TRichEdit, но и в RxRichEdit, стандартный виндовый RichEdit, etc.
Author: Krid
Source: Взято из http://forum.sources.ru
ID: 00582
----
uses
 RichEdit;
// Stream Callback function
type
 TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;
 cb: Longint; var pcb: Longint): DWORD;
 stdcall;
 TEditStream = record
 dwCookie: Longint;
 dwError: Longint;
 pfnCallback: TEditStreamCallBack;
 end;
 // RichEdit Type
type
 TMyRichEdit = TRxRichEdit;
// EditStreamInCallback callback function
// by P. Below
function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;
 cb: Longint; var pcb: Longint): DWORD; stdcall;
var
 theStream: TStream;
 dataAvail: LongInt;
begin
 theStream := TStream(dwCookie);
 with theStream do
 begin
 dataAvail := Size - Position;
 Result := 0;
 if dataAvail <= cb then
 begin
 pcb := read(pbBuff^, dataAvail);
 if pcb <> dataAvail then
 Result := UINT(E_FAIL);
 end
 else
 begin
 pcb := read(pbBuff^, cb);
 if pcb <> cb then
 Result := UINT(E_FAIL);
 end;
 end;
end;
// Insert Stream into RichEdit
// by P. Below
procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);
var
 EditStream: TEditStream;
begin
 with EditStream do
 begin
 dwCookie := Longint(SourceStream);
 dwError := 0;
 pfnCallback := EditStreamInCallBack;
 end;
 RichEdit.Perform(EM_STREAMIN, SF_RTF or SFF_SELECTION, Longint(@EditStream));
end;
// Convert Bitmap to RTF Code
// by D3k
function BitmapToRTF(pict: TBitmap): string;
var
 bi, bb, rtf: string;
 bis, bbs: Cardinal;
 achar: ShortString;
 hexpict: string;
 I: Integer;
begin
 GetDIBSizes(pict.Handle, bis, bbs);
 SetLength(bi, bis);
 SetLength(bb, bbs);
 GetDIB(pict.Handle, pict.Palette, PChar(bi)^, PChar(bb)^);
 rtf := '{\rtf1 {\pict\dibitmap ';
 SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
 I := 2;
 for bis := 1 to Length(bi) do
 begin
 achar := Format('%x', [Integer(bi[bis])]);
 if Length(achar) = 1 then
 achar := '0' + achar;
 hexpict[I - 1] := achar[1];
 hexpict[I] := achar[2];
 Inc(I, 2);
 end;
 for bbs := 1 to Length(bb) do
 begin
 achar := Format('%x', [Integer(bb[bbs])]);
 if Length(achar) = 1 then
 achar := '0' + achar;
 hexpict[I - 1] := achar[1];
 hexpict[I] := achar[2];
 Inc(I, 2);
 end;
 rtf := rtf + hexpict + ' }}';
 Result := rtf;
end;
// Example to insert image from Image1 into RxRichEdit1 
procedure TForm1.Button1Click(Sender: TObject);
var
 SS: TStringStream;
 BMP: TBitmap;
begin
 BMP := TBitmap.Create;
 BMP := Image1.Picture.Bitmap;
 SS := TStringStream.Create(BitmapToRTF(BMP));
 try
 PutRTFSelection(RxRichEdit1, SS);
 finally
 SS.Free;
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 01022