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

Материал из DRKB

Как вставить 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