如何实现点击一个按钮,就向RichEdit插入一个图片(就像QQ的插入心情图标)

Question

如何实现点击一个按钮,就向RichEdit插入一个图片(就像QQ的插入心情图标)

Answer 1

找到这个,不知道能不能实现我的想法..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;  
**************************************** 
下面的代码可以不调用那个InsertObject的对话框而直接插入一张图片： 
var 
  Bmp:TBitmap; 
begin 
  if not OpenPictureDialog1.Execute then exit; 
  Bmp:=TBitmap.Create; 
  Bmp.LoadFromFile(OpenPictureDialog1.FileName); 
  Clipboard.Assign(BMP); 
  RxRichEdit201.PasteFromClipboard; 
  Bmp.Free; 
end; 
************************************** 
： TechnoFantasy(www.applevb.com)  
RichEdit中，插入图片 
代码: procedure proPrintRTFWithBMP(strCaption,strPic,strTitle:string;rtf:TRichEdit); 
{strText为要打印的文本 strCaption为打印标题 strPic为图像文件目录 
strTitle为要显示在图像右侧的图像标题} 
var 
  FRTF:IRichEditOle; 
  FOLE:IOLEObject; 
  formatEtc:tagFORMATETC; 
  FStorage :ISTORAGE; 
  FClientSite:IOLECLIENTSITE; 
  FLockBytes:ILockBytes; 
  ReObject:TReObject; 
  xt:TGuid; 
  FTemp:IUnknown; 
  strTemp:string; 
  bCreateNew:boolean; 
  ABMP:TBitmap; 
  Ajpeg:TJpegImage; 
  i:Longint; 
begin 
//    rtfTemp:=TRichEdit.Create(frmPrintFrame); 
    try 
{        with  rtfTemp do 
        begin 
            Parent := frmPrintFrame; 
            width:=200; 
            height:=200; 
            visible:=false; 
            Text := strText; 
        end;  }         //图片文件不存在，直接打印文本并退出 
        if not fileexists(strPic)then 
        begin 
            PrintRichEdit(strCaption,rtf); 
            exit; 
        end;         abmp:=TBitmap.Create; 
        ajpeg:= TJpegImage.Create; 
        try 
            if ExtractFileExt(strPic)='.jpg' then 
            begin 
                bCreateNew:=true; 
                ajpeg.LoadFromFile(strPic); 
                abmp.Assign(ajpeg); 
                strTemp:=ExtractFilePath(strPic)+'0099www.bmp'; 
                abmp.SaveToFile(strTemp); 
                for i:=1 to 30000 do 
                    application.ProcessMessages; 
            end 
            else 
                strTemp:= strPic; 
        finally 
            abmp.Free; 
            ajpeg.free; 
            abmp:=nil; 
            ajpeg:=nil; 
        end;         sendmessage(rtf.handle,EM_GETOLEINTERFACE,0,LongInt(@FRTF)); 
        if not assigned(FRTF)then 
        begin 
            showmessage('Error to get Richedit OLE interface'); 
            exit; 
        end;         //建立一个可以访问全局内存的Byte数组 FLockBytes 
        //返回ILockBytes接口 
        if CreateILockBytesOnHGlobal(0,true,FLockBytes)<>S_OK then 
        begin 
            showmessage('Error to create Global Heap'); 
            exit; 
        end;         //建立一个混合文档存取对象 
        if StgCreateDocfileOnILockBytes(FLockBytes,STGM_SHARE_EXCLUSIVE or 
            STGM_CREATE or STGM_READWRITE,0,FStorage)<>S_OK then 
        begin 
            showmessage('Error to create storage'); 
            exit; 
        end; 
         
        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(strTemp)),IID_IUnknown,0,@formatEtc, 
            FClientSite,FStorage,FOLE)<>S_OK then 
        begin 
            showmessage('Error'); 
            exit; 
        end;         //现在的FOLE还是一个IUnKnown接口，将其转换为一个 IOleObject接口 
        FTemp:=FOLE; 
        FTemp.QueryInterface(IID_IOleObject, FOle); 
        OleSetContainedObject(FOle, TRUE); 
        //step 2 
        reobject.cbStruct := sizeof(TReObject); 
        FOLE.GetUserClassID(xt); 
        ReObject.clsid := xt; 
        reobject.cp := ULong(REO_CP_SELECTION); 
        reobject.dvaspect := DVASPECT_CONTENT; 
        reobject.dwFlags := ULong(REO_RESIZABLE) 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);         PrintRichEdit(strCaption,rtf); 
    finally 
        if bCreateNew then 
            Deletefile(strTemp); 
        FRTF:=nil; 
        FOLE:=nil; 
    end; 
end; 

Answer 2

还有上面的代码是一个在RTF控件当前位置插入图像并打印的，你运行上面的代码需要首先引用 
ActiveX, ComObj, RichEdit, Jpeg 
并且将PrintRichEdit(strCaption,rtf);去掉 
以下的结构是需要手工加入的： type 
  _ReObject = record 
    cbStruct: DWORD;           { Size of structure                } 
    cp: ULONG;                 { Character position of object     } 
    clsid: TCLSID;             { Class ID of object               } 
    poleobj: IOleObject;       { OLE object interface             } 
    pstg: IStorage;            { Associated storage interface     } 
    polesite: IOleClientSite;  { Associated client site interface } 
    sizel: TSize;              { Size of object (may be 0,0)      } 
    dvAspect: Longint;         { Display aspect to use            } 
    dwFlags: DWORD;            { Object status flags              } 
    dwUser: DWORD;             { Dword for user's use             } 
  end; 
  TReObject = _ReObject;   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; Type TCharRange=record 
    cpMin:integer; 
    cpMax:integer; 
End; Type TFormatRange=record 
    hdc : Integer; 
    hdcTarget:integer; 
    rectRegion:trect; 
    rectPage:trect; 
    chrg : TCharRange; 
End; 
************************************ 
以下不通过剪切板而直接在Richedit中插入一张图片： 
var  
  frmMain: TfrmMain;  implementation  {$R *.DFM}  
{$R Smiley.res}  uses  
  RichEdit;  type  
  TEditStreamCallBack = function(dwCookie: Longint; pbBuff: PByte;  
    cb: Longint; var pcb: Longint): DWORD;  
  stdcall;    TEditStream = record  
    dwCookie: Longint;  
    dwError: Longint;  
    pfnCallback: TEditStreamCallBack;  
  end;  type  
  TMyRichEdit = TRxRichEdit;  // EditStreamInCallback callback function  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  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;  // Load a smiley image from resource  function GetSmileyCode(ASimily: string): string;  
var  
  dHandle: THandle;  
  pData, pTemp: PChar;  
  Size: Longint;  
begin  
  pData := nil;  
  dHandle := FindResource(hInstance, PChar(ASimily), RT_RCDATA);  
  if dHandle <> 0 then  
  begin  
    Size := SizeofResource(hInstance, dHandle);  
    dhandle := LoadResource(hInstance, dHandle);  
    if dHandle <> 0 then  
      try  
        pData := LockResource(dHandle);  
        if pData <> nil then  
          try  
            if pData[Size - 1] = #0 then  
            begin  
              Result := StrPas(pTemp);  
            end  
            else  
            begin  
              pTemp := StrAlloc(Size + 1);  
              try  
                StrMove(pTemp, pData, Size);  
                pTemp[Size] := #0;  
                Result := StrPas(pTemp);  
              finally  
                StrDispose(pTemp);  
              end;  
            end;  
          finally  
            UnlockResource(dHandle);  
          end;  
      finally  
        FreeResource(dHandle);  
      end;  
  end;  
end;  procedure InsertSmiley(ASmiley: string);  
var  
  ms: TMemoryStream;  
  s: string;  
begin  
  ms := TMemoryStream.Create;  
  try  
    s := GetSmileyCode(ASmiley);  
    if s <> '' then  
    begin  
      ms.Seek(0, soFromEnd);  
      ms.Write(PChar(s)^, Length(s));  
      ms.Position := 0;  
      PutRTFSelection(frmMain.RXRichedit1, ms);  
    end;  
  finally  
    ms.Free;  
  end;  
end;  procedure TfrmMain.SpeedButton1Click(Sender: TObject);  
begin  
  InsertSmiley('Smiley1');  
end;  procedure TfrmMain.SpeedButton2Click(Sender: TObject);  
begin  
  InsertSmiley('Smiley2');  
end;  // Replace a :-) or :-( with a corresponding smiley  procedure TfrmMain.RxRichEdit1KeyPress(Sender: TObject; var Key: Char);  
var  
 sCode, SmileyName: string;    procedure RemoveText(RichEdit: TMyRichEdit);  
  begin  
    with RichEdit do  
    begin  
      SelStart := SelStart - 2;  
      SelLength := 2;  
      SelText :=  '';  
    end;  
  end;  begin  
 If (Key = ')') or (Key = '(')  then  
 begin  
   sCode := Copy(RxRichEdit1.Text, RxRichEdit1.SelStart-1, 2) + Key;  
   SmileyName := '';  
   if sCode = ':-)'  then SmileyName := 'Smiley1';  
   if sCode = ':-('  then SmileyName := 'Smiley2';  
   if SmileyName <> '' then  
   begin  
     Key := #0;  
     RemoveText(RxRichEdit1);  
     InsertSmiley('Smiley1');  
   end;  
 end;  
end; 

Answer 3

我也正在做這方面的問題：
procedure TForm1.Button1Click(Sender: TObject);  
var
      vc : TCanvas;
begin
      vc := TCanvas.Create;
      vc.Handle := GetDC(RichEdit1.Handle);
     vc.Brush.Style := bsClear;
      vc.StretchDraw(Image1.ClientRect, Image1.Picture.Graphic);
end;