Richedit中插入图片

Tags: /超级猛料/VCL/Memo&Edit&Richedit/RichEdit、RxRichEdit/ Date Created:

unit RichEditImg;

interface

uses

Windows, ActiveX, Variants, RichEdit;

procedure InsertBitmap(ARichEditHandle:HWND;ABitmap:HBITMAP;AData:DWORD);

implementation

const

IID_IOleObject: TGUID = (

D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

IID_IDataObject: TGUID = (

D1:$0000010E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

type

PIOleObject = ^IOleObject;

TImageDataObject = class(TInterfacedObject, IDataObject)

private

FStgMed : TStgMedium;

FFormat : TFormatEtc;

public

constructor Create;

procedure SetBitmap(ABitmap:HBITMAP);

function GetOleObject(var AClientSite:IOleClientSite; var AStorage:IStorage):IOleObject;

{ 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;

end;

{ TImageDataObject }

constructor TImageDataObject.Create;

begin

end;

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.GetData(const formatetcIn: TFormatEtc;

out medium: TStgMedium): HResult;

var

HDst : THANDLE;

begin

HDst := OleDuplicateData(FStgMed.hBitmap, CF_BITMAP, 0);

if HDst=0 then

begin

Result:=E_HANDLE;

Exit;

end;

with medium do

begin

tymed := TYMED_GDI;

hBitmap := hDst;

unkForRelease := nil;

end;

Result:=S_OK;

end;

function TImageDataObject.GetDataHere(const formatetc: TFormatEtc;

out medium: TStgMedium): HResult;

begin

Result:=E_NOTIMPL;

end;

function TImageDataObject.GetOleObject(var AClientSite: IOleClientSite;

var AStorage: IStorage): IOleObject;

var

AOleObjectPtr : IOleObject;

sc : SCODE;

begin

Result:=nil;

sc:=OleCreateStaticFromData(self as IDataObject, IID_IOleObject, OLERENDER_FORMAT,

@FFormat, AClientSite, AStorage, AOleObjectPtr);

if S_OK=sc then

Result:=AOleObjectPtr;

end;

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

begin

Result:=E_NOTIMPL;

end;

procedure TImageDataObject.SetBitmap(ABitmap: HBITMAP);

var

AStgm : TStgMedium;

AFormat : TFormatEtc;

begin

if ABitmap=0 then Exit;

with AStgm do

begin

tymed := TYMED_GDI; // Storage medium = HBITMAP handle

hBitmap := ABitmap;

unkForRelease:=Nil; // Use ReleaseStgMedium

end;

with AFormat do

begin

cfFormat := CF_BITMAP; // Clipboard format = CF_BITMAP

ptd := Nil; // Target Device = Screen

dwAspect := DVASPECT_CONTENT; // Level of detail = Full content

lindex := -1; // Index = Not applicaple

tymed := TYMED_GDI; // Storage medium = HBITMAP handle

end;

SetData(AFormat, AStgm, TRUE);

end;

function TImageDataObject.SetData(const formatetc: TFormatEtc;

var medium: TStgMedium; fRelease: BOOL): HResult;

begin

FStgMed:=Medium;

FFormat:=formatetc;

Result:=S_OK;

end;

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;

const

{ Place object at selection }

REO_CP_SELECTION = ULONG(-1);

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;

procedure InsertBitmap(ARichEditHandle:HWND;ABitmap:HBITMAP;AData:DWORD);

var

ImgDataObj : TImageDataObject;

RichEditOle : IRichEditOle;

DataObj : IDataObject;

AClientSite : IOleClientSite;

AStorage : IStorage;

LockBytes : ILockBytes;

AOleObject : IOleObject;

ReObject : TReObject;

ClsID : TCLSID;

begin

// Get the image data object

ImgDataObj := TImageDataObject.Create;

ImgDataObj.QueryInterface(IID_IDataObject,DataObj);

ImgDataObj.SetBitmap(ABitmap);

// Get the RichEdit container site

if 0=SendMessage(ARichEditHandle, EM_GETOLEINTERFACE, 0, Longint(@RichEditOle)) then

Exit;

RichEditOle.GetClientSite(AClientSite);

// Initialize a Storage Object

if S_OK<>CreateILockBytesOnHGlobal(0, TRUE, LockBytes) then

Exit;

if S_OK<>StgCreateDocfileOnILockBytes(LockBytes,

STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, AStorage) then

Exit;

// The final ole object which will be inserted in the richedit control

AOleObject:=ImgDataObj.GetOleObject(AClientSite, AStorage);

// all items are "contained" -- this makes our reference to this object

// weak -- which is needed for links to embedding silent update.

OleSetContainedObject(AOleObject, TRUE);

// Now Add the object to the RichEdit

ZeroMemory(@ReObject,sizeof(ReObject));

ReObject.cbStruct := sizeof(REOBJECT);

if S_OK<>AOleObject.GetUserClassID(clsid) then

Exit;

with ReObject do

begin

clsid := clsid;

cp := REO_CP_SELECTION;

dvaspect := DVASPECT_CONTENT;

poleobj := AOleObject;

polesite := AClientSite;

pstg := AStorage;

dwUser := AData;

end;

// Insert the bitmap at the current location in the richedit control

RichEditOle.InsertObject(reobject);

end;

end.

---------------------------------------

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;

// 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;

****************************************

下面的代码可以不调用那个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;

上面的代码是一个在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;

// 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;

finally

UnlockResource(dHandle);

end;

finally

FreeResource(dHandle);

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;

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;

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;