richunt.pas

絮语2007视频聊天软件源程序.仅供参考

unit richunt;

interface

uses
  Windows, messages,SysUtils,Classes,comctrls,Graphics,olerichedit,constunt;
  
  procedure initrichedit(var rt:trichedit);
  procedure rolltoend(var rt:trichedit);
  procedure firendnamefont(var editor:trichedit;isme:boolean);
  procedure firendfont(var editor:trichedit;isme:boolean);

  function destyle(styles:tfontstyles):string;
  function enstyle(s:string):tfontstyles;

  procedure strtopic(startpos:integer;var oleedit:trichedit);
  function parsepicturetomd5(var oleedit:toleedit):string;
  function parsemd5topicture(Bool:boolean;startpos:integer;var oleedit:Toleedit):string;
  procedure paraspicture(startpos:integer;md5str:string;var oleedit:toleedit);

  procedure parsechartopicture(startpos:integer;var oleedit:Toleedit);
  function RegisterOleFile (strOleFileName : STRING; OleAction : Byte ) : BOOLEAN;


implementation
uses shareunit,udpcores;

//------------------------------------------------------------------------------
//字体解析
//------------------------------------------------------------------------------
function destyle(styles:tfontstyles):string;
var s:string;
begin
s:='0000';
if fsbold in styles then s[1]:='1';
if fsitalic in styles then s[2]:='1';
if fsunderline in styles then s[3]:='1';
if fsstrikeout in styles then s[4]:='1';
result:=s;
end;

function enstyle(s:string):tfontstyles;
var styles:tfontstyles;
begin
styles:=[];
if length(s)=4 then
 begin
 if s[1]='1' then styles:=styles+[fsbold];
 if s[2]='1' then styles:=styles+[fsitalic];
 if s[3]='1' then styles:=styles+[fsunderline];
 if s[4]='1' then styles:=styles+[fsstrikeout];
 end;
result:=styles;
end;


//------------------------------------------------------------------------------
// 初始化 richedit
//------------------------------------------------------------------------------
procedure initrichedit(var RT:trichedit);
begin
RT.clear;
with rt.Paragraph do
  begin
  FirstIndent:=10;
  RightIndent:=10;
  end;
end;
//------------------------------------------------------------------------------
// 光标滚动到尾
//------------------------------------------------------------------------------
procedure rolltoend(var rt:trichedit);
begin
rt.selstart:=length(rt.text);
SendMessage(rt.Handle, EM_SCROLLCARET, 0, 0);
end;
//------------------------------------------------------------------------------
// 设置richedit font
//------------------------------------------------------------------------------
procedure firendnamefont(var editor:trichedit;isme:boolean);
begin
editor.selAttributes.Size:=9;
editor.selAttributes.Name:='宋体';
editor.selAttributes.style :=[];
editor.selAttributes.color:=clblue;
if isme then editor.selAttributes.color:=clgreen;
editor.Paragraph.FirstIndent:=0;
end;

procedure firendfont(var editor:trichedit;isme:boolean);
begin
if isme then
  begin
  editor.selAttributes.Size:=udpcore.myfont.Font.Size;
  editor.selAttributes.Name:=udpcore.myfont.Font.name;
  editor.selAttributes.style :=udpcore.myfont.Font.Style;
  editor.selAttributes.color:=udpcore.myfont.Font.color;
  end else begin
  editor.selAttributes.Size:=udpcore.tempfont.Font.Size;
  editor.selAttributes.Name:=udpcore.tempfont.Font.name;
  editor.selAttributes.style :=udpcore.tempfont.Font.Style;
  editor.selAttributes.color:=udpcore.tempfont.Font.color;
  end;
editor.Paragraph.FirstIndent:=10;
end;

//------------------------------------------------------------------------------
// 将字转义符换为 PICTURE MD5STR
//------------------------------------------------------------------------------
procedure strtopic(startpos:integer;var oleedit:trichedit);
var foundat,Fstartpos,Flength:longint;
    md5str,params:string;
    i,n:integer;
begin
oleedit.Perform(WM_SetRedraw, 0, 0);

if facelist.Count>0 then
for i:=1 to facelist.count do
    begin
    params:=facelist.strings[i-1];
    md5str:=copy(params,1,34);
    n:=pos('/',params);
    delete(params,1,n-1);
    Fstartpos:=startpos;
    Flength:=length(oleedit.text)-Fstartpos;
    foundat:=oleedit.FindText(params,Fstartpos,Flength,[stMatchCase]);
     while foundat<>-1 do
       begin
       Fstartpos:=foundat;
       oleedit.SelStart:=Fstartpos;
       oleedit.SelLength:=length(params);
       oleedit.SelText:=md5str;
       Flength:=length(oleedit.text)-Fstartpos;
       foundat:=oleedit.FindText(params,Fstartpos,Flength,[stMatchCase]);
       end;
    end;

oleedit.Perform(WM_SetRedraw, 1, 0);
oleedit.Repaint;
end;

//------------------------------------------------------------------------------
// 将 pic 换为 PICTURE MD5STR
//------------------------------------------------------------------------------
function parsepicturetomd5(var oleedit:toleedit):string;
var i,m:integer;
    str:string;
begin
if oleedit.GetObjectCounts>0 then
  begin
  oleedit.Perform(WM_SetRedraw, 0, 0);
  m:=length(oleedit.text);
  for i:=m downto 1 do
  if oleedit.text[i]=chr(32) then
    begin
    oleedit.SelStart:=i;
    oleedit.SelLength:=-1;
    if oleedit.objectselected then
      begin
      str:=oleedit.getpicfilename;
      if str<>'' then str:='{'+md5encodefile(str)+'}';
      oleedit.seltext:=str;
      end;
    end;
  oleedit.Perform(WM_SetRedraw, 1, 0);
  oleedit.Repaint;
  end;
result:=oleedit.text;
oleedit.clear;
oleedit.setfocus;
end;

//------------------------------------------------------------------------------
//  直译 PICTURE MD5STR 为pic
//------------------------------------------------------------------------------
function parsemd5topicture(Bool:boolean;startpos:integer;var oleedit:Toleedit):string;
var str,picfilename:string;
    tmplist:tstringlist;
    foundat,Fstartpos,Flengths:longint;
begin
try
oleedit.Perform(WM_SetRedraw, 0, 0);
tmplist:=Tstringlist.create;

Fstartpos:=startpos;
Flengths:=length(oleedit.text)-startpos;
foundat:=oleedit.FindText('{',Fstartpos,Flengths,[]);
while foundat<>-1 do
  begin
  oleedit.SelStart:=foundat;
  oleedit.SelLength:=34;
  str:=oleedit.SelText;
  if str[34]='}' then
     begin
     picfilename:=udpcore.pic.getmd5tofile(str);
     if fileexists(picfilename) then
        begin
        oleedit.SelText:='';
        oleedit.SelLength:=0;
        oleedit.Insertpicture(picfilename);
        end else begin
        if not Bool then
           begin
           oleedit.SelText:='';
           oleedit.SelLength:=0;
           oleedit.Insertpicture(udpcore.pic.getmd5tofile(blackpic));
           end else begin
           oleedit.SelLength:=0;
           Fstartpos:=Fstartpos+33;
           tmplist.Add(str);
           end;
        end;
     end else Fstartpos:=foundat+1;
  Flengths:=length(oleedit.text)-Fstartpos;
  foundat:=oleedit.FindText('{',Fstartpos,Flengths,[]);
  end;
result:=trim(tmplist.Text);
finally
freeandnil(tmplist);
oleedit.Perform(WM_SetRedraw, 1, 0);
oleedit.Repaint;
end;
end;

procedure paraspicture(startpos:integer;md5str:string;var oleedit:toleedit);
var picfilename:string;
    foundat,Fstartpos,Flengths:longint;
begin
oleedit.Perform(WM_SetRedraw, 0, 0);
Fstartpos:=startpos;
Flengths:=length(oleedit.text)-startpos;
picfilename:=udpcore.pic.getmd5tofile(md5str);
if fileexists(picfilename) then
    begin
    foundat:=oleedit.FindText(md5str,Fstartpos,Flengths,[]);
    while foundat<>-1 do
      begin
      oleedit.SelStart:=foundat;
      oleedit.SelLength:=34;
      oleedit.SelText:='';
      oleedit.SelLength:=0;
      oleedit.Insertpicture(picfilename);
      Flengths:=length(oleedit.text)-Fstartpos;
      foundat:=oleedit.FindText(md5str,Fstartpos,Flengths,[]);
      end;
    end;

oleedit.Perform(WM_SetRedraw, 1, 0);
oleedit.Repaint;

end;

//------------------------------------------------------------------------------
//  直译 char 为pic
//------------------------------------------------------------------------------
procedure parsechartopicture(startpos:integer;var oleedit:Toleedit);
var params,md5str:string;
    foundat,Fstartpos,Flength,i:longint;
begin
if newpictext_ok then
    begin
    oleedit.Perform(WM_SetRedraw, 0, 0);

    if charlist.Count>0 then
    for i:=1 to charlist.count do
        begin
        params:=charlist.strings[i-1];
        md5str:=copy(params,1,34);
        delete(params,1,34);
        Fstartpos:=startpos;
        Flength:=length(oleedit.text)-Fstartpos;
        foundat:=oleedit.FindText(params,Fstartpos,Flength,[]);
         while foundat<>-1 do
           begin
           Fstartpos:=foundat;
           oleedit.SelStart:=Fstartpos;
           oleedit.SelLength:=length(params);
           oleedit.SelText:='';
           oleedit.SelLength:=0;
           oleedit.Insertpicture(udpcore.pic.getmd5tofile(md5str));
           Flength:=length(oleedit.text)-Fstartpos;
           foundat:=oleedit.FindText(params,Fstartpos,Flength,[]);
           end;
        end;
    
    oleedit.Perform(WM_SetRedraw, 1, 0);
    oleedit.Repaint;
    end;
end;

//------------------------------------------------------------------------------
// 注册 imageole.dll
//------------------------------------------------------------------------------
function RegisterOleFile (strOleFileName : STRING; OleAction : Byte ) : BOOLEAN;
const
    RegisterOle = 1;//注册
    UnRegisterOle = 0;//卸载
type
    TOleRegisterFunction = function : HResult;//注册或卸载函数的原型
var
    hLibraryHandle : THandle;//由LoadLibrary返回的DLL或OCX句柄
    hFunctionAddress: TFarProc;//DLL或OCX中的函数句柄，由GetProcAddress返回
    RegFunction : TOleRegisterFunction;//注册或卸载函数指针
begin
Result := FALSE;
//打开OLE/DCOM文件，返回的DLL或OCX句柄
hLibraryHandle := LoadLibrary(PCHAR(strOleFileName));
if (hLibraryHandle > 0) then//DLL或OCX句柄正确
   try
      //返回注册或卸载函数的指针
      if (OleAction = RegisterOle) then
          hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllRegisterServer')) //返回注册函数的指针
      else  hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllUnregisterServer')); //返回卸载函数的指针
      if (hFunctionAddress <> NIL) then//注册或卸载函数存在
          begin
          RegFunction := TOleRegisterFunction(hFunctionAddress);//获取操作函数的指针
          if RegFunction >= 0 then //执行注册或卸载操作，返回值>=0表示执行成功
              result := true;
          end;
   finally
      FreeLibrary(hLibraryHandle);//关闭已打开的OLE/DCOM文件
   end;
end;

end.