我已经从网上找到将BMP文件写入RichEdit控件的方法(见下面程序源码)。
但我想将TImage中的Bitmap写入RichEdit控件,请问哪位大侠能够指点指点!万分感谢!!!
unit InsRich;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,ActiveX,ComCtrls;
const
REO_CP_SELECTION = ULONG(-1);
REO_BELOWBASELINE = $00000002;
REO_RESIZABLE = $00000001;
REO_STATIC = $40000000;
EM_GETOLEINTERFACE = WM_USER + 60;
IID_IUnknown: TGUID = (D1:$00000000;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));
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;
TCharRange = record {Copy From RichEdit.pas}
cpMin: Integer;
cpMax: Integer;
end;
TFormatRange = record
hdc: Integer;
hdcTarget: Integer;
rectRegion: TRect;
rectPage: TRect;
chrg: TCharRange;
end;
IRichEditOle = interface(System.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;
function InsertBitmap(Editor: TRichEdit; BmpFile: String): Boolean;implementationfunction InsertBitmap(Editor: TRichEdit; BmpFile: String): Boolean;
var
FRTF: IRichEditOle;
FOle: IOleObject;
FormatEtc: tagFormatETC;
FStorage: ISTORAGE;
FClientSite: IOleClientSite;
FLockBytes: ILockBytes;
ReObject: TReObject;
xt: TGuid;
FTemp: IUnknown;
begin
Result:=false;
if not FileExists(BmpFile) then Exit;
try
SendMessage(Editor.Handle, em_GetOleInterFace, 0, LongInt(@FRTF));
if not Assigned(FRTF) then Exit;
if CreateILockBytesOnHGlobal(0,true,FLockBytes)<>S_OK then Exit;
if StgCreateDocfileOnILockBytes(FLockBytes,STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE,0,FStorage)<>S_OK then Exit;
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(BmpFile)),IID_IUnknown,0,@FormatEtc,FClientSite,FStorage,FOle)<>S_OK then Exit;
FTemp:=FOle;
FTemp.QueryInterface(IID_IOleObject, FOle);
OleSetContainedObject(FOle, true);
ReObject.cbStruct:=SizeOf(TReObject);
FOle.GetUserClassID(xt);
ReObject.clsid:=xt;
ReObject.cp:=ULong(REO_CP_SELECTION);
ReObject.dvaspect:=DVASPECT_CONTENT;
ReObject.dwFlags:=ULong(REO_STATIC) 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);
finally
FRTF:=nil;
FOle:=nil;
end;
Result:=true;
end;
end.
但我想将TImage中的Bitmap写入RichEdit控件,请问哪位大侠能够指点指点!万分感谢!!!
unit InsRich;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,ActiveX,ComCtrls;
const
REO_CP_SELECTION = ULONG(-1);
REO_BELOWBASELINE = $00000002;
REO_RESIZABLE = $00000001;
REO_STATIC = $40000000;
EM_GETOLEINTERFACE = WM_USER + 60;
IID_IUnknown: TGUID = (D1:$00000000;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));
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;
TCharRange = record {Copy From RichEdit.pas}
cpMin: Integer;
cpMax: Integer;
end;
TFormatRange = record
hdc: Integer;
hdcTarget: Integer;
rectRegion: TRect;
rectPage: TRect;
chrg: TCharRange;
end;
IRichEditOle = interface(System.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;
function InsertBitmap(Editor: TRichEdit; BmpFile: String): Boolean;implementationfunction InsertBitmap(Editor: TRichEdit; BmpFile: String): Boolean;
var
FRTF: IRichEditOle;
FOle: IOleObject;
FormatEtc: tagFormatETC;
FStorage: ISTORAGE;
FClientSite: IOleClientSite;
FLockBytes: ILockBytes;
ReObject: TReObject;
xt: TGuid;
FTemp: IUnknown;
begin
Result:=false;
if not FileExists(BmpFile) then Exit;
try
SendMessage(Editor.Handle, em_GetOleInterFace, 0, LongInt(@FRTF));
if not Assigned(FRTF) then Exit;
if CreateILockBytesOnHGlobal(0,true,FLockBytes)<>S_OK then Exit;
if StgCreateDocfileOnILockBytes(FLockBytes,STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE,0,FStorage)<>S_OK then Exit;
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(BmpFile)),IID_IUnknown,0,@FormatEtc,FClientSite,FStorage,FOle)<>S_OK then Exit;
FTemp:=FOle;
FTemp.QueryInterface(IID_IOleObject, FOle);
OleSetContainedObject(FOle, true);
ReObject.cbStruct:=SizeOf(TReObject);
FOle.GetUserClassID(xt);
ReObject.clsid:=xt;
ReObject.cp:=ULong(REO_CP_SELECTION);
ReObject.dvaspect:=DVASPECT_CONTENT;
ReObject.dwFlags:=ULong(REO_STATIC) 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);
finally
FRTF:=nil;
FOle:=nil;
end;
Result:=true;
end;
end.
解决方案 »
- 如何用正则表达式表示一个字符串X中既包含字符串A,并且不包含字符串B?
- 删除access中的重复记录
- 有关delphi中的rave报表分栏问题,其实在我看来也不太难,高分请教,在线等!!!
- 如何判断文件正在被使用
- 关于ShellTreeView的两个问题,delphi自带的控件呀,不过好像很少人知道
- 两个DBLookupComboBox的主从查询问题,令人头痛
- 用ClientDataset连接一50万记录的TABLE,程序在激活时(ClientDataset.Active:=True)怎么会这么慢??
- 有关ADO数据库的问题。特急
- 为什么不能循环使用GetMem和FreeMem。还有,循环使用TStringList.create和Free也会出错!!
- 请教;如何在程序中修改短日期格式?
- 向各位算法高手求个算法,海量关键词过滤
- ACCESS delete
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ComCtrls, RxRichEd;type
TForm1 = class(TForm)
Button1: TButton;
RxRichEdit1: TRxRichEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;var
Form1: TForm1;implementation
uses
JPEG;{$R *.dfm}function ConvertBitmapToRTF(const Bitmap: TBitmap): string;
var
bi, bb: string;
bis, bbs: Cardinal;
achar: string[2];
Buffer: string;
I: Integer;
type
PWord = ^Word;
begin
GetDIBSizes(Bitmap.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(Bitmap.Handle, Bitmap.Palette, PChar(bi)^, PChar(bb)^);
SetLength(Buffer, (Length(bb) + Length(bi)) * 2);
i := 1;
for bis := 1 to Length(bi) do
begin
achar := IntToHex(Integer(bi[bis]), 2);
PWord(@Buffer[i])^ := PWord(@achar[1])^;
inc(i, 2);
end;
for bbs := 1 to Length(bb) do
begin
achar := IntToHex(Integer(bb[bbs]), 2);
PWord(@Buffer[i])^ := PWord(@achar[1])^;
inc(i, 2);
end;
Result := '{\rtf1 {\pict\dibitmap ' + Buffer + ' }}';
end;procedure InsertBitmapIntoRxRichEdit(const Bitmap: TBitmap; const RxRichEdit:
TRxRichEdit); overload;
begin
RxRichEdit.SelText := ConvertBitmapToRTF(Bitmap);
RxRichEdit.SelLength := 0;
RxRichEdit.SelStart := RxRichEdit.SelStart + 1;
end;procedure InsertBitmapIntoRxRichEdit(const GraphicFileName: string; const
RxRichEdit: TRxRichEdit); overload;
var
Bitmap: TBitmap;Graphic: TPicture;
begin
Graphic := TPicture.Create;
try
Graphic.LoadFromFile(GraphicFileName);if Graphic.Graphic is TBitmap then
Bitmap := Graphic.Bitmap
else
begin
Bitmap := TBitmap.Create;
Bitmap.Assign(Graphic.Graphic);
end;InsertBitmapIntoRxRichEdit(Bitmap, RxRichEdit);
finally
if Bitmap <> Graphic.Bitmap then
FreeAndNil(Bitmap);FreeAndNil(Graphic);
end;
end;procedure TForm1.Button1Click(Sender: TObject);
begin
//InsertBitmapIntoRxRichEdit('C:\Temp\Untitled.bmp', RxRichEdit1);
InsertBitmapIntoRxRichEdit('C:\Temp\Untitled-8.jpg', RxRichEdit1);
RxRichEdit1.SetFocus;
end;
end.
但我不想用RxRichEdit,我说的是标准RichEdit。
再次恳请大侠指点!!!
var
Bmp: TBitmap;
begin
Bmp := TBitmap.Create;
Bmp.LoadFromFile('test.bmp');
JvRichEdit1.InsertGraphic(Bmp,True);
Bmp.Free;
end;
我想既然从图片文件中可以提取,那么从TImage中更应该可以提取!
http://bbs.2ccc.com/topic.asp?topicid=238581
你提供的:http://bbs.2ccc.com/topic.asp?topicid=238581给了我很大启发,问题已经解决了!
再次感谢你的帮助!