用DELPHIRxRichEdit控件实现类似QQ的表情输入方法

Posted 2023-02-24 射天狼

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

源码及DLL 附件下载地址：
http://www.j2soft.cn

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.