shareunit.pas

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

unit shareunit;

interface

uses
  Windows, Messages, SysUtils,Classes,gwbleep,filectrl,Math,
  IdHash,IdHashMessageDigest,CvCode,structureunt;

var
  logmemo,      //运行日志
  msgmemo,      //自动回复
  expandmemo,   //临时数据堆栈
  facelist,     //表情贴图列表
  charlist,     //字符贴图列表
  searchiplist  //IP列表
  :tstringlist;

//------------------------------------------------------------------------------
// 全局BOOL变量
//------------------------------------------------------------------------------
  login_ok,                                //登陆成功
  login_hide,                              //隐身登陆
  file_supervention,                     //文件存在时续传
  newmsg_sound,                          //声音提醒
  newmsg_popup,                          //自动弹出
  winstart_run,                          //随windows启动
  autoaccept_file,                       //自动接收文件
  starting_mini,                         //启动时最小化
  closetomin,                            //点关闭时最小化
  playsound_pc,                          //播放PC还是WAV
  newpictext_ok,                         //图形文字

  //对话框
  allow_auto_status,                     //允许自动转换状态
  pressenter_send,                       //按回车发送消息
  sidehide,                              //侧边隐藏..
  
  //语音视频
  startvideo,                            //开始VIDEO 播放过程..
  startaudio,                            //开始audio  播放过程..
  videoisok,                            // 视频设备OK
  audioisok,                            // 音频设备OK

  //主界面
  showonline,                           //只显示在线用户
  showupdownhint,                       //显示上下线提示
  showmyicon                            //显示自己

  :boolean;

//------------------------------------------------------------------------------
// 全局字符变量
//------------------------------------------------------------------------------

  cur_seluser,                          //当前所选用户名
  playsound_code,                      // 播放 PC 内容
  playwave_code,                       // 播放 wave 内容
  mylocalip,                           //本机内部IP
  mycomputername,                      //本机电脑名称
  loginuser,                           //当前用户
  loginpass,                           //当前用户登陆密码
  revertmsg,                           //当前设定的自动回复语
  autopath,                            //文件接收默认路径.
  application_name                    //应用程序名
  :string;

//------------------------------------------------------------------------------
// 全局整型变量
//------------------------------------------------------------------------------


  video_index,                            //视频设备索引号
  audio_index,                            //音频输出设备索引号
  mic_index,                             //音频输入设备索引号
  video_use,                             //视频使用数...

  skinindex,                           //外观颜色.
  skinclarity,                         // 透明度

  status_outtime,                      //状态操时
  auto_status,                         //操时后的状态
  core_port,                           //基本通讯端口
  systemhot_key,                       //系统热键
  bosshot_key                             //老板键...
  :integer;
//------------------------------------------------------------------------------
// 全局 handle 用于消息传递
//------------------------------------------------------------------------------
  main_hwnd,
  remote_hwnd,
  search_hwnd:hwnd;
  hwndlist:array of Thwndinfo;
  Codestr:TCvCode;

function isnt:boolean;
function WhichLanguage:boolean;
function locallanguage:string;
function statustostr(n:integer):string;
procedure languageconversion(var params:string);

function md5encode(s:string):string;overload;
function md5encode(tmpstream:Tstream):string;overload;
function md5encodefile(s:string):string;

procedure playpc(s:string);
function getmaxvol(s:String):integer;
function fixvol(s:string;yawpvol:integer):string;

//字符压缩，解压
function encode(s:string):string;
function decode(s:string):string;

//字符编码..
procedure makeparamsex(var source:string;funid,param:string); overload;
procedure makeparamsex(var source:string;funid:string;param:integer); overload;
procedure makeparamsex(var source:string;funid:string;param:real); overload;
procedure makeparamsex(var source:string;funid:string;param:boolean); overload;

function getparamitem(params,item:string):string; overload;
function getparamitem(params:string;item:integer):string; overload;

procedure  FindFile(const filespec: TFileName;list:TStringList;sub:boolean);

function getipheard(s:string):string;
function checkip(s:string):boolean;
function LocalIP:string;
function Localname:string;
procedure addiptohistorylist(s:string);
procedure readhistoryiplist;
procedure opencmd(s:string);
function randomstr:string;
function replacestr(sourcestr,oldstr,newstr:String):string;

function selectpath(var path:string):boolean;
procedure createdirectorys(s:string);
function getfilesize(files:string):integer;
function nowtimedefer(n:integer):tdatetime;
function makepacket(msgid:word;curpos,compos:longword):string;
function fixfilelistpath(newpath,filelist:string):string;
function fixdirectory(s:string):string;
//------------------------------------------------------------------------------
// 受控的 handle list
//------------------------------------------------------------------------------
function gethwndtoid(hd:hwnd):integer;
procedure addhwnd(hd:hwnd);
procedure delhwnd(hd:hwnd);
procedure sendmsgtohwnd(msgid:integer);

implementation
uses constunt,IdStack,shellapi,mmsystem;

function getfilesize(files:string):integer;
begin
with tfilestream.create(files,fmopenread or fmShareDenyRead) do
   try
   result:=size;
   finally
   free;
   end;
end;

function fixdirectory(s:string):string;
begin
if length(s)<>3 then
  begin
  delete(s,length(s),1);
  while s[length(s)]<>'\' do
    delete(s,length(s),1);
  end;
result:=s;
end;

function fixfilelistpath(newpath,filelist:string):string;
var tmplist:tstringlist;
    i:integer;s:string;
begin
try
tmplist:=tstringlist.create;
tmplist.Text:=filelist;
if tmplist.count>0 then
for i:=1 to tmplist.count do
  begin
  s:=tmplist.Strings[i-1];
  if length(s)>length(newpath) then
     begin
     s:=replacestr(s,newpath,'');
     tmplist.Strings[i-1]:=s;
     end;
  end;
result:=tmplist.Text;
finally
freeandnil(tmplist);
end;

end;

function selectpath(var path:string):boolean;
begin
result:=false;
if selectdirectory('选择路径',path,path) then
   begin
   if path[length(path)]<>'\' then path:=path+'\';
   result:=true;
   end;
end;

procedure createdirectorys(s:string);
var n:integer;x,c:string;
begin
c:=s;
while pos('\',c)<>0 do
   begin
   n:=pos('\',c);
   x:=copy(s,1,n);
   if not directoryexists(x) then createdir(x); 
   c[n]:='/';
   end;
end;

function makepacket(msgid:word;curpos,compos:longword):string;
var tmpack:tdatapack;
    msgs:string;
begin
tmpack.msgid:=msgid;
tmpack.curpos:=curpos;
tmpack.compos:=compos;
setlength(msgs,sizeof(tdatapack));
with tmemorystream.create do
  try
  writebuffer(tmpack,sizeof(tdatapack));
  Seek(0,soFromBeginning);
  readbuffer(msgs[1],sizeof(tdatapack));
  finally
  free;
  end;
result:=msgs;
end;

function nowtimedefer(n:integer):tdatetime;
var h,m,s,ms:word;
begin
decodetime(time,h,m,s,ms);
result:=date+encodetime(h,m,s+n,ms);
end;

function randomstr:string;
begin
result:=inttostr(random(maxint));
end;

//------------------------------------------------------------------------------
// 字符 替换
//------------------------------------------------------------------------------
function replacestr(sourcestr,oldstr,newstr:String):string;
begin
result:=StringReplace(sourcestr,oldstr,newstr,[rfReplaceAll, rfIgnoreCase]);
end;

//------------------------------------------------------------------------------
// 运行指定的命令行
//------------------------------------------------------------------------------
procedure opencmd(s:string);
begin
shellexecute(getdc(0),nil,pchar(s),nil,nil,1);
end;

//------------------------------------------------------------------------------
// 添加IP到搜索列表
//------------------------------------------------------------------------------
procedure addiptohistorylist(s:string);
var n:integer;
begin
n:=searchiplist.IndexOf(s)+1;
if n=0 then searchiplist.Add(s);
end;

//------------------------------------------------------------------------------
// 读取 搜索IP列表
//------------------------------------------------------------------------------
procedure readhistoryiplist;
var s,x:String;i,n:integer;
begin
s:=extractfilepath(application_name)+'dat\iplist.txt';
if fileexists(s) then searchiplist.LoadFromFile(s);
n:=gstack.LocalAddresses.Count;
for i:=1 to n do
 begin
 x:=gstack.localaddresses.Strings[i-1];
 addiptohistorylist(x);
 end;
end;

//------------------------------------------------------------------------------
// 返回本地IP地址
//------------------------------------------------------------------------------
function LocalIP:string;
var n:integer;
begin
n:=gstack.LocalAddresses.Count;
if n=1 then result:=GStack.LocalAddress else
   result:=gstack.localaddresses.Strings[n-1];
end;

function Localname:string;
begin
result:=gstack.WSGetHostName;
end;

//------------------------------------------------------------------------------
// 验证IP地址合法性
//------------------------------------------------------------------------------
function checkip(s:string):boolean;
begin
result:=false;
if length(s)>0 then
   result:=Gstack.IsIP(s);
end;

function getipheard(s:string):string;
var i,k:integer;
begin
k:=length(s);
for i:=k downto 1 do
 begin
 if (s[i]='.') then break;
 delete(s,i,1);
 end;
result:=s;
end;
//------------------------------------------------------------------------------
// 播放 pc 喇叭
//------------------------------------------------------------------------------
procedure playpc(s:string);
 function checkmusic:boolean;
 var x:string;i:integer;
 begin
 x:='000000';
 for i:=1 to length(s) do
  if not (s[i] in ['A','B','C','D','E','F','G','M','N','L','S','O','P','<','>','0'..'9']) then
     begin
     x[6]:='1';
     break;
     end;
 if s[1]<>'M' then x[1]:='1';
 if s[3]<>'O' then x[2]:='1';
 if s[5]<>'L' then x[3]:='1';
 if not (s[2] in ['N','S','L']) then x[4]:='1';
 if not (s[4] in ['1'..'7']) then x[5]:='1';
 if x='000000' then  result:=true else result:=false;
 end;
begin
playstop;
if length(s)<8 then s:='MSO7L4BBPBBPBBP';
if checkmusic then playbleep(s);
end;

procedure play_stop_pc;
begin
playstop;
end;



function getmaxvol(s:String):integer;
var i,maxvol:integer;
    bitrec:array of integer;
begin
setlength(bitrec,length(s));
for i:=low(bitrec) to high(bitrec) do
    bitrec[i]:=ord(s[i+1]);
maxvol:=MaxIntValue(bitrec);
inc(maxvol,-128);
if maxvol>128 then maxvol:=128;
result:=maxvol;
end;

function fixvol(s:string;yawpvol:integer):string;
var maxvol:integer;
begin
maxvol:=getmaxvol(s)+128;
if maxvol<yawpvol then
   FillChar(s[1],length(s),#128);
result:=s;
end;
//------------------------------------------------------------------------------