Richedit中插入图片BMP(BMP,文件),GIF(文件)

unit RichEx; 


{
2005-03-04 LiChengbin
Added:
   Insert bitmap or gif into RichEdit controls from source file.}

2005-01-31 LiChengbin
Usage:
   Insert bitmap into RichEdit controls by IRichEditOle interface and
  implementation of IDataObject interface.

Example:
   InsertBitmap(RichEdit1.Handle, Image1.Picture.Bitmap);

interface

uses Windows, Messages, Graphics, ActiveX, ComObj;

const

// Flags to specify which interfaces should be returned in the structure above
REO_GETOBJ_NO_INTERFACES = $00000000;
REO_GETOBJ_POLEOBJ = $00000001;
REO_GETOBJ_PSTG = $00000002;
REO_GETOBJ_POLESITE = $00000004;
REO_GETOBJ_ALL_INTERFACES = $00000007;

// Place object at selection
REO_CP_SELECTION = $FFFFFFFF;

// Use character position to specify object instead of index
REO_IOB_SELECTION = $FFFFFFFF;
REO_IOB_USE_CP = $FFFFFFFF;

// object flags
REO_NULL = $00000000; // No flags
REO_READWRITEMASK = $0000003F; // Mask out RO bits
REO_DONTNEEDPALETTE = $00000020; // object doesn't need palette
REO_BLANK = $00000010; // object is blank
REO_DYNAMICSIZE = $00000008; // object defines size always
REO_INVERTEDSELECT = $00000004; // object drawn all inverted if sel
REO_BELOWBASELINE = $00000002; // object sits below the baseline
REO_RESIZABLE = $00000001; // object may be resized
REO_LINK = $80000000; // object is a link (RO)
REO_STATIC = $40000000; // object is static (RO)
REO_SELECTED = $08000000; // object selected (RO)
REO_OPEN = $04000000; // object open in its server (RO)
REO_INPLACEACTIVE = $02000000; // object in place active (RO)
REO_HILITED = $01000000; // object is to be hilited (RO)
REO_LINKAVAILABLE = $00800000; // Link believed available (RO)
REO_GETMETAFILE = $00400000; // object requires metafile (RO){0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}';
CLASS_GifAnimator: TGUID = '{06ADA938-0FB0-4BC0-B19B-0A38AB17F182}';
end;
TReObject = _ReObject;

// flags for IRichEditOle::GetClipboardData(),
// IRichEditOleCallback::GetClipboardData() and
// IRichEditOleCallback::QueryAcceptData()
RECO_PASTE = $00000000; // paste from clipboard
RECO_DROP = $00000001; // drop
RECO_COPY = $00000002; // copy to the clipboard
RECO_CUT = $00000003; // cut to the clipboard
RECO_DRAG = $00000004; // drag

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

IID_IGifAnimator: TGUID = '

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         

TCharRange = record
   cpMin: Integer;
   cpMax: Integer;
end;

TFormatRange = record
   hdc: Integer;
   hdcTarget: Integer;
   rectRegion: TRect;
   rectPage: TRect;
   chrg: TCharRange;
end;

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;

// *********************************************************************//
// interface: IGifAnimator
// Flags:    (4544) Dual NonExtensible OleAutomation Dispatchable
// GUID:     {0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}
// *********************************************************************//
IGifAnimator = interface(IDispatch)
   ['{0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}']
  procedure LoadFromFile(const FileName: WideString); safecall;
  function TriggerFrameChange: WordBool; safecall;
  function GetFilePath: WideString; safecall;
  procedure ShowText(const Text: WideString); safecall;
end;

// *********************************************************************//
// DispIntf: IGifAnimatorDisp
// Flags:    (4544) Dual NonExtensible OleAutomation Dispatchable
// GUID:     {0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}
// *********************************************************************//
IGifAnimatorDisp = dispinterface
   ['{0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}']
  procedure LoadFromFile(const FileName: WideString); dispid 1;
  function TriggerFrameChange: WordBool; dispid 2;
  function GetFilePath: WideString; dispid 3;
  procedure ShowText(const Text: WideString); dispid 4;
end;

TBitmapOle = class(TInterfacedObject, IDataObject)
private
   FStgm: TStgMedium;
   FFmEtc: TFormatEtc;

  procedure SetBitmap(hBitmap: HBITMAP);
  procedure GetOleObject(OleSite: IOleClientSite; Storage: IStorage;
    var OleObject: IOleObject);
public
  { ======================================================================= }
  { implementation of IDataObject interface }
  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;

function InsertBitmap(hRichEdit: THandle; const FileName: string): Boolean; overload;
function InsertBitmap(hRichEdit: THandle; Bitmap: TBitmap): Boolean; overload;
function InsertGif(hRichEdit: THandle; const FileName: string): Boolean;

implementation

function GetRichEditOle(hRichEdit: THandle): IRichEditOle;
begin
SendMessage(hRichEdit, EM_GETOLEINTERFACE, 0, Longint(@Result));
end;

function GetImage(Bitmap: TBitmap): HBITMAP;
var
Dest: HBitmap;
DC, MemDC: HDC;
OldBitmap: HBITMAP;
begin
DC := GetDC(0);
MemDC := CreateCompatibleDC(DC);
try
   Dest := CreateCompatibleBitmap(DC, Bitmap.Width, Bitmap.Height);
   OldBitmap := SelectObject(MemDC, Dest);
   BitBlt(MemDC, 0, 0, Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, 0, 0, SRCCOPY);
   SelectObject(MemDC, OldBitmap);
finally
   DeleteDC(MemDC);
   ReleaseDC(0, DC);
end;
Result := Dest;
end;

function TBitmapOle.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
begin
medium.tymed := TYMED_GDI;
medium.hBitmap := OleDuplicateData(FStgm.hBitmap, CF_BITMAP, 0);
medium.unkForRelease := nil;
if medium.hBitmap = 0 then
   Result := E_HANDLE
else
   Result := S_OK;
end;

function TBitmapOle.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.GetCanonicalFormatEtc(const formatetc: TFormatEtc;
out formatetcOut: TFormatEtc): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.SetData(const formatetc: TFormatEtc; var medium: TStgMedium;
fRelease: BOOL): HResult; stdcall;
begin
FStgm := medium;
FFmEtc := formatetc;
Result := S_OK;
end;

function TBitmapOle.EnumFormatEtc(dwDirection: Longint; out enumFormatEtc:
IEnumFormatEtc): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.DAdvise(const formatetc: TFormatEtc; advf: Longint;
const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.DUnadvise(dwConnection: Longint): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

function TBitmapOle.EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
begin
Result := E_NOTIMPL;
end;

procedure TBitmapOle.GetOleObject(OleSite: IOleClientSite;
Storage: IStorage; var OleObject: IOleObject);
begin
OleCheck(OleCreateStaticFromData(Self, IID_IOleObject,
   OLERENDER_FORMAT, @FFmEtc, OleSite, Storage, OleObject));
end;

procedure TBitmapOle.SetBitmap(hBitmap: HBITMAP);
var
Stgm: TStgMedium;
FmEtc: TFormatEtc;
begin
Stgm.tymed := TYMED_GDI;         // Storage medium = HBITMAP handle
Stgm.hBitmap := hBitmap;
Stgm.unkForRelease := nil;

FmEtc.cfFormat := CF_BITMAP;     // Clipboard format = CF_BITMAP
FmEtc.ptd := nil;             // Target Device = Screen
FmEtc.dwAspect := DVASPECT_CONTENT; // Level of detail = Full content
FmEtc.lindex := -1;           // Index = Not applicaple
FmEtc.tymed := TYMED_GDI;       // Storage medium = HBITMAP handle

SetData(FmEtc, Stgm, True);
end;

function InsertBitmap(hRichEdit: THandle; const FileName: string): Boolean;
var
ReOle: IRichEditOle;
OleSite: IOleClientSite;
Storage: IStorage;
LockBytes: ILockBytes;
OleObject: IOleObject;
ReObj: TReObject;
TempOle: IUnknown;
FormatEtc: TFormatEtc;
begin
ReOle := GetRichEditOle(hRichEdit);
Assert(ReOle <> nil, 'RichEditOle is null!');

ReOle.GetClientSite(OleSite);

OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
Assert(LockBytes <> nil, 'LockBytes is null!');

OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
   STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, Storage));
Assert(Storage <> nil, 'Storage is null!');

OleCheck(OleCreateFromFile(GUID_NULL, PWideChar(WideString(FileName)),
   IID_IUnknown, 0, @FormatEtc, OleSite, Storage, TempOle));
OleCheck(TempOle.QueryInterface(IID_IOleObject, OleObject));
OleCheck(OleSetContainedObject(OleObject, True));
Assert(OleObject <> nil, 'OleObject is null!');

FillChar(ReObj, Sizeof(ReObj), 0);
ReObj.cbStruct := Sizeof(ReObj);
OleCheck(OleObject.GetUserClassID(ReObj.clsid));
ReObj.cp := REO_CP_SELECTION;
ReObj.dvaspect := DVASPECT_CONTENT;
ReObj.poleobj := OleObject;
ReObj.polesite := OleSite;
ReObj.pstg := Storage;
ReObj.dwUser := 0;
ReObj.sizel.cx := 0;
ReObj.sizel.cy := 0;

ReOle.InsertObject(ReObj);
Result := True;
end;

function InsertBitmap(hRichEdit: THandle; Bitmap: TBitmap): Boolean;
var
ReOle: IRichEditOle;
BitmapOle: TBitmapOle;
OleSite: IOleClientSite;
Storage: IStorage;
LockBytes: ILockBytes;
OleObject: IOleObject;
ReObj: TReObject;
begin
ReOle := GetRichEditOle(hRichEdit);
Assert(ReOle <> nil, 'RichEditOle is null!');
BitmapOle := TBitmapOle.Create;
try
   BitmapOle.SetBitmap(GetImage(Bitmap));
   ReOle.GetClientSite(OleSite);

   OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
   Assert(LockBytes <> nil, 'LockBytes is null!');

   OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
     STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, Storage));
   Assert(Storage <> nil, 'Storage is null!');

   BitmapOle.GetOleObject(OleSite, Storage, OleObject);
   OleCheck(OleSetContainedObject(OleObject, True));

   FillChar(ReObj, Sizeof(ReObj), 0);
   ReObj.cbStruct := Sizeof(ReObj);
   OleCheck(OleObject.GetUserClassID(ReObj.clsid));
   ReObj.cp := REO_CP_SELECTION;
   ReObj.dvaspect := DVASPECT_CONTENT;
   ReObj.poleobj := OleObject;
   ReObj.polesite := OleSite;
   ReObj.pstg := Storage;

   ReOle.InsertObject(ReObj);
   Result := True;
finally
   BitmapOle.Free;
end;
end;

function InsertGif(hRichEdit: THandle; const FileName: string): Boolean;
var
ReOle: IRichEditOle;
OleSite: IOleClientSite;
Storage: IStorage;
LockBytes: ILockBytes;
OleObject: IOleObject;
ReObj: TReObject;
Animator: IGifAnimator;
begin
ReOle := GetRichEditOle(hRichEdit);
Assert(ReOle <> nil, 'RichEditOle is null!');
Assert(FileName <> '', 'FileName is null!');

ReOle.GetClientSite(OleSite);

OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
Assert(LockBytes <> nil, 'LockBytes is null!');

OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
   STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0, Storage));
Assert(Storage <> nil, 'Storage is null!');

Animator := IUnknown(CreateComObject(CLASS_GifAnimator)) as IGifAnimator;
Animator.LoadFromFile(PWideChar(WideString(FileName)));
OleCheck(Animator.QueryInterface(IID_IOleObject, OleObject));

OleCheck(OleSetContainedObject(OleObject, True));
FillChar(ReObj, Sizeof(ReObj), 0);
ReObj.cbStruct := Sizeof(ReObj);
OleCheck(OleObject.GetUserClassID(ReObj.clsid));
ReObj.cp := REO_CP_SELECTION;
ReObj.dvaspect := DVASPECT_CONTENT;
ReObj.dwFlags := REO_STATIC or REO_BELOWBASELINE;
ReObj.dwUser := 0;
ReObj.poleobj := OleObject;
ReObj.polesite := OleSite;
ReObj.pstg := Storage;
ReObj.sizel.cx := 0;
ReObj.sizel.cy := 0;

ReOle.InsertObject(ReObj);
Result := True;
end;

end.


//测试： 
RichEx.InsertBitmap(RichEdit1.Handle, ExtractFilePath(ParamStr(0)) + 'e.bmp');
RichEx.InsertBitmap(RichEdit1.Handle, Image1.Picture.Bitmap);
RichEx.InsertGif(RichEdit1.Handle, ExtractFilePath(ParamStr(0)) + 'c.gif'