向TRichEdit插入图片的单元

很简单, 就3个函数, 直接看代码吧

unit RichEditBmp;

{
 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 = $;
 REO_GETOBJ_POLEOBJ = $;
 REO_GETOBJ_PSTG = $;
 REO_GETOBJ_POLESITE = $;
 REO_GETOBJ_ALL_INTERFACES = $;

// 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 = $; // No flags
 REO_READWRITEMASK = $0000003F; // Mask out RO bits
 REO_DONTNEEDPALETTE = $; // Object doesn't need palette
 REO_BLANK = $; // Object is blank
 REO_DYNAMICSIZE = $; // Object defines size always
 REO_INVERTEDSELECT = $; // Object drawn all inverted if sel
 REO_BELOWBASELINE = $; // Object sits below the baseline
 REO_RESIZABLE = $; // Object may be resized
 REO_LINK = $; // Object is a link (RO)
 REO_STATIC = $; // Object is static (RO)
 REO_SELECTED = $; // Object selected (RO)
 REO_OPEN = $; // Object open in its server (RO)
 REO_INPLACEACTIVE = $; // Object in place active (RO)
 REO_HILITED = $; // Object is to be hilited (RO)
 REO_LINKAVAILABLE = $; // Link believed available (RO)
 REO_GETMETAFILE = $; // Object requires metafile (RO)

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

 EM_GETOLEINTERFACE  = WM_USER + ;

 IID_IUnknown: TGUID =
   (D1:$;D2:$;D3:$;D4:($C0,$,$,$,$,$,$,$));
 IID_IOleObject: TGUID =
   (D1:$;D2:$;D3:$;D4:($C0,$,$,$,$,$,$,$));

 IID_IGifAnimator: TGUID = '{0C1CF2DF-05A3-4FEF-8CD4-F5CFC4355A16}';
 CLASS_GifAnimator: TGUID = '{06ADA938-0FB0-4BC0-B19B-0A38AB17F182}';

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
   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 ;
   function  TriggerFrameChange: WordBool; dispid ;
   function  GetFilePath: WideString; dispid ;
   procedure ShowText(const Text: WideString); dispid ;
 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(AREHandle: THandle; const FileName: string): Boolean; overload;
function InsertBitmap(AREHandle: THandle; Bitmap: TBitmap): Boolean; overload;
function InsertGif(AREHandle: THandle; const FileName: string): Boolean;

implementation

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

function GetImage(Bitmap: TBitmap): HBITMAP;
var
Dest: HBitmap;
DC, MemDC: HDC;
 OldBitmap: HBITMAP;
begin
 DC := GetDC();
 MemDC := CreateCompatibleDC(DC);
 try
   Dest := CreateCompatibleBitmap(DC, Bitmap.Width, Bitmap.Height);
   OldBitmap := SelectObject(MemDC, Dest);
   BitBlt(MemDC, , , Bitmap.Width, Bitmap.Height, Bitmap.Canvas.Handle, , , SRCCOPY);
   SelectObject(MemDC, OldBitmap);
 finally
   DeleteDC(MemDC);
   ReleaseDC(, 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, );
 medium.unkForRelease := nil;
 if medium.hBitmap =  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 := -;                 // Index = Not applicaple
 FmEtc.tymed := TYMED_GDI;           // Storage medium = HBITMAP handle

 SetData(FmEtc, Stgm, True);
end;

function InsertBitmap(AREHandle: 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(AREHandle);
 Assert(ReOle <> nil, 'RichEditOle is null!');

 ReOle.GetClientSite(OleSite);

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

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

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

 FillChar(ReObj, Sizeof(ReObj), );
 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 := ;
 ReObj.sizel.cx := ;
 ReObj.sizel.cy := ;

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

function InsertBitmap(AREHandle: THandle; Bitmap: TBitmap): Boolean;
var
  nIRE: IRichEditOle;
  nBMP: TBitmapOle;
  nIOleSite: IOleClientSite;
  nIStorage: IStorage;
  nILockBytes: ILockBytes;
  nIOleObject: IOleObject;
  nREObj: TReObject;
begin
  nIRE := GetRichEditOle(AREHandle);
  Assert(nIRE <> nil, 'RichEditOle is null');
  nBMP := TBitmapOle.Create;
  try
    nBMP.SetBitmap(GetImage(Bitmap));
    nIRE.GetClientSite(nIOleSite);

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

    OleCheck(StgCreateDocfileOnILockBytes(nILockBytes,
    STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, , nIStorage));
    Assert(nIStorage <> nil, 'Storage is null');

    nBMP.GetOleObject(nIOleSite, nIStorage, nIOleObject);
    OleCheck(OleSetContainedObject(nIOleObject, True));

    FillChar(nREObj, Sizeof(nREObj), );
    nREObj.cbStruct := Sizeof(nREObj);
    OleCheck(nIOleObject.GetUserClassID(nREObj.clsid));
    nREObj.cp := REO_CP_SELECTION;
    nREObj.dvaspect := DVASPECT_CONTENT;
    nREObj.poleobj := nIOleObject;
    nREObj.polesite := nIOleSite;
    nREObj.pstg := nIStorage;

    nIRE.InsertObject(nREObj);
    Result := True;
  finally
    nBMP.Free;
  end;
end;

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

 ReOle.GetClientSite(OleSite);

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

 OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
   STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, , 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), );
 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 := ;
 ReObj.poleobj := OleObject;
 ReObj.polesite := OleSite;
 ReObj.pstg := Storage;
 ReObj.sizel.cx := ;
 ReObj.sizel.cy := ;

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

end.