开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 界面编程 > RichEdit > 查看源码
re_bmp.pas
资源名称：re_bmp.zip　[点击查看]
上传用户：com600
上传日期：2020-07-29
资源大小：2k
文件大小：7k
源码类别：

RichEdit

开发平台：

Delphi

re_bmp.pas：源码内容
  1. unit re_bmp;
  3. interface
  5. uses Windows;
  7. procedure InsertBitmapToRE(Wnd:HWND; Bmp:HBITMAP);
  9. implementation
  11. uses Activex, RichEdit;
  13. const
  14. IID_IDataObject: TGUID = (
  15.   D1:$0000010E;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  16. IID_IOleObject: TGUID = (
  17.    D1:$00000112;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
  18. REO_CP_SELECTION    = ULONG(-1);
  19. REO_IOB_SELECTION   = ULONG(-1);
  20. REO_GETOBJ_POLEOBJ  =  $00000001;
  22. type
  23. TReobject = record
  24.    cbStruct: DWORD;
  25.    cp: ULONG;
  26.    clsid: TCLSID;
  27.    poleobj: IOleObject;
  28.    pstg: IStorage;
  29.    polesite: IOleClientSite;
  30.    sizel: TSize;
  31.    dvAspect: Longint;
  32.    dwFlags: DWORD;
  33.    dwUser: DWORD;
  34. end;
  36. type
  37. IRichEditOle = interface(IUnknown)
  38.    ['{00020d00-0000-0000-c000-000000000046}']
  39.    function GetClientSite(out clientSite: IOleClientSite): HResult; stdcall;
  40.    function GetObjectCount: HResult; stdcall;
  41.    function GetLinkCount: HResult; stdcall;
  42.    function GetObject(iob: Longint; out reobject: TReObject;
  43.      dwFlags: DWORD): HResult; stdcall;
  44.    function InsertObject(var reobject: TReObject): HResult; stdcall;
  45.    function ConvertObject(iob: Longint; rclsidNew: TIID;
  46.      lpstrUserTypeNew: LPCSTR): HResult; stdcall;
  47.    function ActivateAs(rclsid: TIID; rclsidAs: TIID): HResult; stdcall;
  48.    function SetHostNames(lpstrContainerApp: LPCSTR;
  49.      lpstrContainerObj: LPCSTR): HResult; stdcall;
  50.    function SetLinkAvailable(iob: Longint; fAvailable: BOOL): HResult; stdcall;
  51.    function SetDvaspect(iob: Longint; dvaspect: DWORD): HResult; stdcall;
  52.    function HandsOffStorage(iob: Longint): HResult; stdcall;
  53.    function SaveCompleted(iob: Longint; const stg: IStorage): HResult; stdcall;
  54.    function InPlaceDeactivate: HResult; stdcall;
  55.    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  56.    function GetClipboardData(var chrg: TCharRange; reco: DWORD;
  57.      out dataobj: IDataObject): HResult; stdcall;
  58.    function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
  59.      hMetaPict: HGLOBAL): HResult; stdcall;
  60. end;
  62. TImageDataObject=class(TInterfacedObject,IDataObject)
  64. private
  65.   FBmp:HBITMAP;
  66.   FMedium:TStgMedium;
  67.   FFormatEtc: TFormatEtc;
  68.   procedure SetBitmap(bmp:HBITMAP);
  69.   function GetOleObject(OleClientSite:IOleClientSite; Storage:IStorage):IOleObject;
  70.   destructor Destroy;override;
  72.   // IDataObject
  74.   function GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
  75.    function GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult; stdcall;
  76.    function QueryGetData(const formatetc: TFormatEtc): HResult; stdcall;
  77.    function GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult; stdcall;
  78.    function SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult; stdcall;
  79.    function EnumFormatEtc(dwDirection: Longint; out enumFormatEtc: IEnumFormatEtc): HResult; stdcall;
  80.    function DAdvise(const formatetc: TFormatEtc; advf: Longint; 
  81.                     const advSink: IAdviseSink; out dwConnection: Longint): HResult; stdcall;
  82.    function DUnadvise(dwConnection: Longint): HResult; stdcall;
  83.    function EnumDAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  85. public
  86.   procedure InsertBitmap(wnd:HWND; Bitmap:HBITMAP);
  88. end;
  90. { TImageDataObject }
  92. function TImageDataObject.DAdvise(const formatetc: TFormatEtc; advf: Integer;
  94. const advSink: IAdviseSink; out dwConnection: Integer): HResult;
  96. begin
  97. Result:=E_NOTIMPL;
  98. end;
  100.  
  102. function TImageDataObject.DUnadvise(dwConnection: Integer): HResult;
  103. begin
  104. Result:=E_NOTIMPL;
  105. end;
  107. function TImageDataObject.EnumDAdvise(out enumAdvise: IEnumStatData): HResult;
  108. begin
  109. Result:=E_NOTIMPL;
  110. end;
  112. function TImageDataObject.EnumFormatEtc(dwDirection: Integer; out enumFormatEtc: IEnumFormatEtc): HResult;
  113. begin
  114. Result:=E_NOTIMPL;
  115. end;
  117. function TImageDataObject.GetCanonicalFormatEtc(const formatetc: TFormatEtc; out formatetcOut: TFormatEtc): HResult;
  118. begin
  119. Result:=E_NOTIMPL;
  120. end;
  122. function TImageDataObject.GetDataHere(const formatetc: TFormatEtc; out medium: TStgMedium): HResult;
  123. begin
  124. Result:=E_NOTIMPL;
  125. end;
  127. function TImageDataObject.QueryGetData(const formatetc: TFormatEtc): HResult;
  128. begin
  129. Result:=E_NOTIMPL;
  130. end;
  132. destructor TImageDataObject.Destroy;
  133. begin
  134. ReleaseStgMedium(FMedium);
  135. end;
  137. function TImageDataObject.GetData(const formatetcIn: TFormatEtc; out medium: TStgMedium): HResult;
  138. begin
  139. medium.tymed := TYMED_GDI;
  140. medium.hBitmap :=  FMedium.hBitmap;
  141. medium.unkForRelease := nil;
  142. Result:=S_OK;
  143. end;
  145. function TImageDataObject.SetData(const formatetc: TFormatEtc; var medium: TStgMedium; fRelease: BOOL): HResult;
  146. begin
  147. FFormatEtc := formatetc;
  148. FMedium := medium;
  149. Result:= S_OK;
  150. end;
  152. procedure TImageDataObject.SetBitmap(bmp: HBITMAP);
  153. var
  154. stgm: TStgMedium;
  155. fm:TFormatEtc;
  156. begin
  157. stgm.tymed := TYMED_GDI;
  158. stgm.hBitmap := bmp;
  159. stgm.UnkForRelease := nil;
  161. fm.cfFormat := CF_BITMAP;
  162. fm.ptd := nil;
  163. fm.dwAspect := DVASPECT_CONTENT;
  164. fm.lindex := -1;
  165. fm.tymed := TYMED_GDI;
  166. SetData(fm, stgm, FALSE);
  167. end;
  169.  
  171. function TImageDataObject.GetOleObject(OleClientSite: IOleClientSite; Storage: IStorage):IOleObject;
  172. begin
  173. if (Fmedium.hBitmap=0) then Result:=nil else
  174. OleCreateStaticFromData(self, IID_IOleObject, OLERENDER_FORMAT, @FFormatEtc, OleClientSite, Storage, Result);
  175. end;
  177. procedure TImageDataObject.InsertBitmap(wnd:HWND; Bitmap: HBITMAP);
  178. var
  179. OleClientSite:IOleClientSite;
  180. RichEditOLE:IRichEditOLE;
  181. Storage:IStorage;
  182. LockBytes:ILockBytes;
  183. OleObject:IOleObject;
  184. reobject:TReobject;
  185. clsid:TGUID;
  186. begin
  187. if (SendMessage(wnd, EM_GETOLEINTERFACE, 0, cardinal(@RichEditOle))=0) then exit;
  188. FBmp:=CopyImage(Bitmap,IMAGE_BITMAP,0,0,0);
  189. if FBmp=0 then exit;
  190. try
  191.   SetBitmap(Fbmp);
  192.   RichEditOle.GetClientSite(OleClientSite);
  193.   if (OleClientSite=nil) then exit;
  194.   CreateILockBytesOnHGlobal(0, TRUE,LockBytes);
  195.   if (LockBytes = nil) then exit;
  196.   if (StgCreateDocfileOnILockBytes(LockBytes, STGM_SHARE_EXCLUSIVE or STGM_CREATE or STGM_READWRITE, 0,Storage)<> S_OK) then
  197.   begin
  198.      LockBytes._Release;
  199.      exit
  200.    end;
  201.   if (Storage = nil) then exit;
  202.   OleObject:=GetOleObject(OleClientSite, Storage);
  203.   if (OleObject = nil) then exit;
  204.   OleSetContainedObject(OleObject, TRUE);
  205.   ZeroMemory(@reobject, sizeof(TReobject));
  206.   reobject.cbStruct := sizeof(TReobject);
  207.   OleObject.GetUserClassID(clsid);
  208.   reobject.clsid := clsid;
  209.   reobject.cp := REO_CP_SELECTION;
  210.   reobject.dvaspect := DVASPECT_CONTENT;
  211.   reobject.poleobj := OleObject;
  212.   reobject.polesite := OleClientSite;
  213.   reobject.pstg := Storage;
  214.   RichEditOle.InsertObject(reobject);
  215. finally
  216.   DeleteObject(FBmp)
  217. end
  218. end;
  220. procedure InsertBitmapToRE(Wnd:HWND; bmp:HBITMAP);
  221. begin
  222. with TImageDataObject.Create do
  223. try
  224. InsertBitmap(Wnd,Bmp);
  225. finally
  226. Free
  227. end
  228. end;
  229. end. 
  230.