TRichEdit

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

Содержание материала

 

Вот так можно вставить картинку в формате Bitmap в позицию курсора в TRichEdit:

Code:

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.

 


Примеры использования:
 

Code:

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.
 
 


Code:

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

function EditStreamInCallback(dwCookie: Longint; pbBuff: PByte;

  cb: Longint; var pcb: Longint): DWORD; stdcall;

  // by P. Below

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

procedure PutRTFSelection(RichEdit: TMyRichEdit; SourceStream: TStream);

  // by P. Below

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

function BitmapToRTF(pict: TBitmap): string;

// by D3k

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;

 

 

Новые статьи

Ранние статьи

Случайные статьи

Популярные статьи

Подробности
Родительская категория: VCL
Категория: TRichEdit

Добавить комментарий

Не использовать не нормативную лексику.

Просьба писать ваши замечания, наблюдения и все остальное,
что поможет улучшить предоставляемую информацию на этом сайте.

ВСЕ КОММЕНТАРИИ МОДЕРИРУЮТСЯ ВРУЧНУЮ, ТАК ЧТО СПАМИТЬ БЕСПОЛЕЗНО!

Защитный код
Обновить