shareunit.pas

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

// 返回当前系统语言
//------------------------------------------------------------------------------
function WhichLanguage:boolean;
var
  ID:LangID;
begin
  ID:=GetSystemDefaultLangID;
  result:=ID=$0804;
end;

function locallanguage:string;
begin
if WhichLanguage then result:='chs' else result:='cht';
end;

function isnt:boolean;
var
osv : TOSVersionInfo;
begin
osv.dwOSVersionInfoSize := sizeof(osv);
GetVersionEx(osv);
if osv.dwPlatformId=VER_PLATFORM_WIN32_NT then
   Result := true else result:=false;
end;
//------------------------------------------------------------------------------
// 加密解密
//------------------------------------------------------------------------------
function XorEncode(const Key, Source: string): String;
var
  I: Integer;
  C: Byte;
begin
  Result := '';
  for I := 1 to Length(Source) do begin
    if Length(Key) > 0 then
      C := Byte(Key[1 + ((I - 1) mod Length(Key))]) xor Byte(Source[I])
    else
      C := Byte(Source[I]);
    Result := Result + AnsiLowerCase(IntToHex(C, 2));
  end;
end;

function XorDecode(const Key, Source: string): String;
var
  I: Integer;
  C: Char;
begin
  Result := '';
  for I := 0 to Length(Source) div 2 - 1 do begin
    C := Chr(StrToIntDef('$' + Copy(Source, (I * 2) + 1, 2), Ord(' ')));
    if Length(Key) > 0 then
      C := Chr(Byte(Key[1 + (I mod Length(Key))]) xor Byte(C));
    Result := Result + C;
  end;
end;

function encode(s:string):string;
begin
result:=XorEncode(floattostr(pi),s)
end;

function decode(s:string):string;
begin
result:=XorDecode(floattostr(pi),s)
end;
//------------------------------------------------------------------------------
// 生成 文件 md5
//------------------------------------------------------------------------------
function md5encodefile(s:string):string;
var tmpstream:Tfilestream;
begin
tmpstream:=Tfilestream.Create(s,fmopenread);
try
result:=md5encode(tmpstream);
finally
freeandnil(tmpstream);
end;
end;

//------------------------------------------------------------------------------
// 生成字符md5
//------------------------------------------------------------------------------
function md5encode(s:string):string;
Var
  Digest: T4x4LongWordRecord;
  Sx,s1: String;
  i: Integer;
begin
  SetLength(Sx, 16);
   with TIdHashMessageDigest5.Create do
     begin
     Digest := HashValue(s);
     Move(Digest, Sx[1], 16);
     Free;
     end;
  for i := 1 to Length(Sx) do
    S1 := S1 + Format('%02x', [Byte(Sx[i])]);
  while Pos(' ', S1) > 0 do S1[Pos(' ', S1)] := '0';
result:=s1;
end;

//------------------------------------------------------------------------------
// 生成流MD5
//------------------------------------------------------------------------------
function md5encode(tmpstream:Tstream):string;
Var
  Digest: T4x4LongWordRecord;
  Sx,s1: String;
  i: Integer;
begin
  SetLength(Sx, 16);
   with TIdHashMessageDigest5.Create do
     begin
     Digest := HashValue(tmpstream);
     Move(Digest, Sx[1], 16);
     Free;
     end;
  for i := 1 to Length(Sx) do
    S1 := S1 + Format('%02x', [Byte(Sx[i])]);
  while Pos(' ', S1) > 0 do S1[Pos(' ', S1)] := '0';
result:=s1;
end;

//------------------------------------------------------------------------------
// 用户状态
//------------------------------------------------------------------------------
function statustostr(n:integer):string;
begin
result:='下线';
case n of
  0:result:='在线';
  1:result:='离开';
  2:result:='隐身';
  3:result:='下线';
 end;
end;

//------------------------------------------------------------------------------
//字符编码
//------------------------------------------------------------------------------
function makeparams(funid,param:string):string;
begin
result:=Concat(LowerCase(funid),'=',encode(param));
end;

//编码扩展
procedure makeparamsex(var source:string;funid,param:string);
var s:String;
begin
with tstringlist.create do
 try
 text:=source;
 s:=makeparams(funid,param);
 add(s);
 sort;
 source:=text;
 finally
 free;
 end;
end;

procedure makeparamsex(var source:string;funid:string;param:integer);
begin
makeparamsex(source,funid,inttostr(param));
end;

procedure makeparamsex(var source:string;funid:string;param:real);
begin
makeparamsex(source,funid,floattostr(param));
end;

procedure makeparamsex(var source:string;funid:string;param:boolean);
begin
if param then makeparamsex(source,funid,xy_true)
         else makeparamsex(source,funid,xy_false);
end;


//------------------------------------------------------------------------------
// 语言转换
//------------------------------------------------------------------------------
procedure languageconversion(var params:string);
var mm:tstringlist;
    i,n:integer; bool:boolean;
    s,x,msg:string;
begin
try
mm:=tstringlist.create;
mm.Text:=params;
bool:=WhichLanguage;

if mm.count>0 then
if locallanguage<>getparamitem(params,'language') then
for i:=1 to mm.count do
 begin
 s:=mm.Strings[i-1];
 n:=pos('=',s);
 if n>0 then
    begin
    x:=copy(s,1,n);
    delete(s,1,n);
    if bool then msg:=codestr.BIG5toGB(decode(s))
       else msg:=codestr.GBtoBIG5(decode(s));
    mm.Strings[i-1]:=x+encode(msg);
    end;
 end;
     
params:=mm.Text;
finally
freeandnil(mm);
end;
end;

//------------------------------------------------------------------------------
//字符解析
//------------------------------------------------------------------------------
function getparamitem(params,item:string):string;
var mm:tstringlist;
    i,n:integer;s:string;
begin
result:='';
item:=LowerCase(item+'=');
try
mm:=tstringlist.create;
mm.Text:=params;
if mm.Count>0 then
for i:=1 to mm.count do
  begin
  s:=mm.Strings[i-1];
  n:=pos(item,s);
  if n=1 then
     begin
     delete(s,1,length(item));
     result:=decode(s);
     break;
     end;
  end;
finally
mm.clear;
freeandnil(mm);
end;
end;

function getparamitem(params:string;item:integer):string;
begin
result:=getparamitem(params,inttostr(item));
end;

//------------------------------------------------------------------------------
// 寻找文件,及子文件
//------------------------------------------------------------------------------
procedure FindFile(const filespec: TFileName;list:TStringList;sub:boolean);
  procedure RFindFile(const folder: TFileName); 
  var 
    SearchRec: TSearchRec; 
  begin
    if FindFirst(folder +'*.*' , faAnyFile , SearchRec)=0 then begin
      try 
        repeat 
          if (SearchRec.Attr and faDirectory = 0) or 
             (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then 
            if fileexists(folder + SearchRec.Name) then
            list.Add(folder + SearchRec.Name);
        until FindNext(SearchRec) <> 0; 
      except
        FindClose(SearchRec); 
        raise; 
      end; 
      FindClose(SearchRec);
    end;
  if sub then
   begin
    if FindFirst(folder + '*.*', faAnyFile
        Or faDirectory, SearchRec) = 0 then 
    begin 
      try 
        repeat 
          if ((SearchRec.Attr and faDirectory) <> 0) and 
             (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then 
            RFindFile(folder + SearchRec.Name + '\');
        until FindNext(SearchRec) <> 0; 
      except
        FindClose(SearchRec); 
        raise; 
      end; 
      FindClose(SearchRec); 
    end;
    end;
  end;

  begin 
    try
      RFindFile(ExtractFilePath(filespec));
    except
      raise; 
    end; 
  end;

//------------------------------------------------------------------------------
// 全局变量初始化
//------------------------------------------------------------------------------
function gethwndtoid(hd:hwnd):integer;
var i:integer;
begin
result:=0;
if high(hwndlist)+1>0 then
for i:=high(hwndlist) downto low(hwndlist) do
if (hwndlist[i].hd=hd)and
  (not hwndlist[i].nullity) then
  begin
  result:=i+1;
  break;
  end;
end;

procedure addhwnd(hd:hwnd);
var n:integer;
begin
if gethwndtoid(hd)=0 then
   begin
   n:=high(hwndlist)+1;
   setlength(hwndlist,n+1);
   hwndlist[n].hd:=hd;
   hwndlist[n].nullity:=false;
   end;
end;

procedure delhwnd(hd:hwnd);
var n:integer;
begin
n:=gethwndtoid(hd);
hwndlist[n-1].nullity:=true;
end;

procedure sendmsgtohwnd(msgid:integer);
var i:integer;
begin
if high(hwndlist)+1>0 then
for i:=high(hwndlist)downto low(hwndlist) do
 if not hwndlist[i].nullity then
    postmessage(hwndlist[i].hd,refresh_status,msgid,0);
end;
//------------------------------------------------------------------------------
// 全局变量初始化
//------------------------------------------------------------------------------
initialization
randomize;
TimeSeparator:=':';
DateSeparator:='-';
ShortDateFormat:='yyyy-mm-dd';
ShortTimeFormat:='hh:mm:ss';
//------------------------------------------------------------------------------
autopath:='c:\';
auto_status:=1;
core_port:=6810;
skinclarity:=255;
playsound_code:='MSO7L4BBPBBPBBP';
playwave_code:='sound\msg.wav';

Codestr:=Tcvcode.Create(nil);
msgmemo:=tstringlist.create;
logmemo:=tstringlist.Create;
facelist:=Tstringlist.create;
charlist:=tstringlist.create;
expandmemo:=tstringlist.create;
searchiplist:=tstringlist.create;


revertmsg:='你好，我现在有事不在，一会儿再和你联系';
msgmemo.Add('你好，我现在有事不在，一会儿再和你联系');
msgmemo.add('工作中，请勿打扰');
msgmemo.add('我去吃饭了，一会儿再联系');
msgmemo.add('我在吃饭，你别吵，我多给你回一条信息就少抢一块肉。');

finalization
hwndlist:=nil;
freeandnil(Codestr);
freeandnil(msgmemo);
freeandnil(logmemo);
freeandnil(facelist);
freeandnil(charlist);
freeandnil(expandmemo);
freeandnil(searchiplist);
end.