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)

// 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 = '{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 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;

Delphi RichEx 图像的更多相关文章

  1. Delphi实现图像文本旋转特效完整代码

    Delphi实现图像文本旋转特效完整代码,本程序利用的控件主要是Panel 控件.Image 控件.Edit 控件.Label 控件和Button 控件.本程序的关键是利用Delphi 的bmp_ro ...

  2. 问题-[Delphi]PixelFormat 图像颜色的数据格式

     PixelFormat: (指定图像中每个像素的颜色数据的格式) Delphi                                        微软                  ...

  3. Delphi制作图像特殊显示效果

    Delphi制作实现图像的各种显示效果,比如百叶窗.渐变.淡入淡出.水平交错.雨滴效果等,用鼠标点击“打开图像”按钮,可以选择图像文件导入到窗体中:点击其它各个按钮,可以实现图像显示特效,例如:点击“ ...

  4. Delphi存取图像完整解决方案

    http://blog.sina.com.cn/s/blog_693cf1cf0100plkq.html 对于涉及图像数据的数据库应用程序,图像数据的存取技术是一个关键.由于缺少技术文档及DEMO例程 ...

  5. delphi图形图像开发相关

    ①delphi的图形处理(doc) http://wenku.baidu.com/view/519df09951e79b89680226ee.html ②delphi的图形图像处理(ppt) http ...

  6. delphi 图像处理 图像左旋右旋

    procedure TDR_QM_ZP_Form.btn_ZXClick(Sender: TObject); //图像左旋 begin screen.Cursor := crhourglass; my ...

  7. delphi 图像处理 图像放大缩小

    procedure TDR_QM_ZP_Form.btn_FDClick(Sender: TObject); //图像放大 begin my_int1 := Trunc( my_int1 * 1.1) ...

  8. Delphi 图形图像对象组件

  9. Delphi经验总结(1)

    先人的DELPHI基础开发技巧 ◇[DELPHI]网络邻居复制文件 uses shellapi; copyfile(pchar('newfile.txt'),pchar('//computername ...

随机推荐

  1. POJ 1125 Stockbroker Grapevine(floyd)

    http://poj.org/problem?id=1125 题意 : 就是说想要在股票经纪人中传播谣言,先告诉一个人,然后让他传播给其他所有的经纪人,需要输出的是从谁开始传播需要的时间最短,输出这个 ...

  2. Ubuntu环境下手动配置ant

    配置ant 1. 下载ant(http://ant.apache.org/bindownload.cgi) 例如我下载的是:apache-ant-1.9.4-bin.tar.gz 解压ant,将文件夹 ...

  3. MSSQLServer基础07(事务,存储过程,分页的存储过程,触发器)

    事务 事务:保证多个操作全部成功,否则全部失败,这处机制就是事务 思考:下了个订单,但是在保存详细信息时出错了,这样可以成功吗? 数据库中的事务:代码全都成功则提交,如果有某一条语句失败则回滚,整体失 ...

  4. PostgreSql中如何kill掉正在执行的sql语句

    虽然可以使用 kill -9 来强制删除用户进程,但是不建议这么去做. 因为:对于执行update的语句来说,kill掉进程,可能会导致Postgres进入到recovery mode 而在recov ...

  5. Java集合框架学习笔记

    集合类的由来:对象用于封装特有数据,对象多了需要存储,如果对象的长度不确定,就使用集合存储. 集合特点1.用于存储对象的容器.2.集合的长度可变.3.集合中不可以存储基本类型 集合容器因为内部的数据结 ...

  6. ggplot2 demo

    title <- rep("A Really Rather Long Text Label", 25)value <- runif(25, 1,10)spacing & ...

  7. 1227. Rally Championship

    1227 题意木看懂 是可以停在路上 任何地方 水题一枚 以下条件之一满足就可以 有环(并查集判) 重边 自己到自己的边 最长边大于s(用flod改写下) #include <iostream& ...

  8. bzoj1997: [Hnoi2010]Planar

    2-SAT. 首先有平面图定理 m<=3*n-6,如果不满足这条件肯定不是平面图,直接退出. 然后构成哈密顿回路的边直接忽略. 把哈密顿回路当成一个圆, 如果俩条边交叉(用心去感受),只能一条边 ...

  9. iOS开发:本地数据存储-NSUserDefaults

    Getting Default Values arrayForKey(_:) boolForKey(_:) dataForKey(_:) dictionaryForKey(_:) floatForKe ...

  10. UVa 1349 (二分图最小权完美匹配) Optimal Bus Route Design

    题意: 给出一个有向带权图,找到若干个圈,使得每个点恰好属于一个圈.而且这些圈所有边的权值之和最小. 分析: 每个点恰好属于一个有向圈 就等价于 每个点都有唯一后继. 所以把每个点i拆成两个点,Xi  ...