delphi在RichEdit控件中插入GIF动画表情
在UDP即时通讯软件中实现类似于QQ的动画表情，在richEdit控件中插入gif动画表情。
发送的时候将表情转为命令，接收之后，再将命令转换为相应的动画表情。
需要引用一个QQ的DLL，文件在附件中。将此DLL导入到DELPHI中。

unit URichEdit;

interface
uses
Windows, Messages, SysUtils, Classes, Controls, StdCtrls, ActiveX, ComCtrls,
RxRichEd, OleServer, ImageOleLib_TLB, coconst, UConst, Dialogs;

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

procedure InsertGif(re: TRxRichEdit; sFileName: string; dwUser: integer);
function GetGif (re: TRxRichEdit): TList;
function ConvertMsgToCmd (re: TRxRichEdit): string;
procedure ConvertMsgToFace (re: TRxRichEdit; strMsg: string);

implementation

//***************************************************
//名称：InsertGif
//功能：插入图片
//输入：re：RichEdit控件；sFileName：要插入的文件名；
// dwUser：（标识，随机数，暂时用文件名【索引】代替）
//输出：
//返回：
//***************************************************
procedure InsertGif(re: TRxRichEdit; sFileName: string; dwUser: integer);
type
tagSize = TSize;
var
FRTF: IRichEditOle;
FLockBytes: ILockBytes;
FStorage: ISTORAGE;
FClientSite: IOLECLIENTSITE;
m_lpObject: IOleObject;
m_lpAnimator: TGifAnimator;
i_GifAnimator: IGifAnimator;
reobject: TReObject;
clsid: TGuid;
sizel: tagSize;
Rect: TRect;
begin
try
if CreateILockBytesOnHGlobal(0, True, FLockBytes) <> S_OK then
begin
//showmessage('Error to create Global Heap');
exit;
end;
//????????????
if StgCreateDocfileOnILockBytes(FLockBytes, STGM_SHARE_EXCLUSIVE or
STGM_CREATE or STGM_READWRITE, 0, FStorage) <> S_OK then
begin
//Showmessage('Error to create storage');
exit;
end;
//??RichEdit???
Sendmessage(re.handle, EM_GETOLEINTERFACE, 0, LongInt(@FRTF));

if FRTF.GetClientSite(FClientSite) <> S_OK then
begin
//ShowMessage('Error to get ClentSite');
Exit;
end;

CoInitializeEx(nil, COINIT_APARTMENTTHREADED);
m_lpAnimator := TGifAnimator.Create(re);
i_GifAnimator := m_lpAnimator.ControlInterface;
i_GifAnimator.LoadFromFile(sFileName);
i_GifAnimator.QueryInterface(IID_IOleObject, m_lpObject);
OleSetContainedObject(m_lpObject, True);
FillChar(ReObject, SizeOf(ReObject), 0);
ReObject.cbStruct := SizeOf(ReObject);
m_lpObject.GetUserClassID(clsid);
ReObject.clsid := clsid;
reobject.cp := REO_CP_SELECTION;
//content, but not static
reobject.dvaspect := DVASPECT_CONTENT;
//goes in the same line of text line
reobject.dwFlags := REO_BELOWBASELINE; //REO_RESIZABLE |
reobject.dwUser := 0;
//the very object
reobject.poleobj := m_lpObject;
//client site contain the object
reobject.polesite := FClientSite;
//the storage
reobject.pstg := FStorage;
sizel.cx := 0;
sizel.cy := 0;
reobject.sizel := sizel;

//Sel all text
re.SelText := '';
re.SelLength := 0;
re.SelStart := re.SelStart;
reobject.dwUser := dwUser;

//Insert after the line of text
FRTF.InsertObject(reobject);
SendMessage(re.Handle, EM_SCROLLCARET, 0, 0);
//VARIANT_BOOL ret;
//do frame changing
m_lpAnimator.TriggerFrameChange();
//show it
m_lpObject.DoVerb(OLEIVERB_UIACTIVATE, nil, FClientSite, 0, re.Handle, Rect);
// m_lpObject.DoVerb(
m_lpObject.DoVerb(OLEIVERB_SHOW, nil, FClientSite, 0, re.Handle, Rect);
//redraw the window to show animation
RedrawWindow(re.Handle, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_FRAME or
RDW_ERASENOW or RDW_ALLCHILDREN);
finally
FRTF := nil;
FClientSite := nil;
FStorage := nil;
end;
end;

//***************************************************
//名称：GetGif
//功能：分析控件内容，取得控件中的图片对象
//输入：re：RichEdit控件；
//输出：
//返回：取得的对象列表（图片索引、图片位置）
//***************************************************
function GetGif (re: TRxRichEdit): TList;
type
tagSize = TSize;
var
i: integer;
FRTF: IRichEditOle;
ReObject: TReObject;
lstGif: TList;
slstRow: TStringList;
begin
lstGif := TList.Create;

Sendmessage(re.handle, EM_GETOLEINTERFACE, 0, LongInt(@FRTF));

for i := 0 to FRTF.GetObjectCount - 1 do
begin
slstRow := TStringList.Create;
FillChar(ReObject, SizeOf(ReObject), 0);
ReObject.cbStruct := SizeOf(ReObject);

FRTF.GetObject (Longint (i), ReObject, REO_BELOWBASELINE);
slstRow.Add (IntToStr (ReObject.dwUser));
slstRow.Add (IntToStr (ReObject.cp));
lstGif.Add (slstRow);
end;

Result := lstGif;
end;

//***************************************************
//名称：ConvertMsgToCmd
//功能：分析控件内容，将表情替换成相应的命令
//输入：re：RichEdit控件；
//输出：
//返回：转换之后的消息内容
//***************************************************
function ConvertMsgToCmd (re: TRxRichEdit): string;
var
i: integer;
lstGif: TList;
strMsg: WideString;
slstRow, slstMsg: TStringList;
begin
//分解消息文本内容，将所有内容分隔之后放到列表中
slstMsg := TStringList.Create;
strMsg := re.Text;
for i := 1 to Length (strMsg) do
begin
slstMsg.Add (strMsg[i]);
end;

//取得表情，将表情替换成命令
lstGif := GetGif (re);
for i := lstGif.Count - 1 downto 0 do
begin
slstRow := TStringList (lstGif.Items[i]);

slstMsg.Insert (StrToInt (slstRow.Strings[1]),
m_arrFace[StrToInt (slstRow.Strings[0]), 1]);
slstRow.Free;
end;
lstGif.Free;

strMsg := StringReplace (slstMsg.Text, #13#10, '', [rfReplaceAll]);
slstMsg.Free;

Result := strMsg;
end;

//***************************************************
//名称：ConvertMsgToFace
//功能：分析消息内容，将命令换成相应的表情
//输入：re：RichEdit控件；strMsg：消息内容；
//输出：
//返回：
//***************************************************
procedure ConvertMsgToFace (re: TRxRichEdit; strMsg: string);
var
i, nFind: integer;
strPath: string;
strMessage: WideString;
begin
if StrPos (PChar (strMsg), '/') = nil then
begin
exit;
end;

strMessage := strMsg;
strPath := ExtractFilePath (ParamStr (0)) + SYSSET_CHAT_FACEPATH;
for i := 0 to Length (m_arrFace) - 1 do
begin
nFind := Pos (PChar (m_arrFace[i, 1]), strMessage);
if nFind = 0 then
continue
else begin
re.SelStart := nFind - 2;
re.SelLength := Length (m_arrFace[i, 1]);
InsertGif (re, strPath + m_arrFace[i, 0], i);
end;
end;
end;

end.