udpcores.pas

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

unit udpcores;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,Forms,AppEvnts,
  IdBaseComponent, IdComponent, IdUDPBase, IdUDPServer, IdAntiFreezeBase,
  IdAntiFreeze,IdSocketHandle,ImgList,Dialogs,compress,WComp, SysHot,

  constunt,plugin,videodx,audiodx,picunt,userunt,structureunt,taskunt,
  chatrec,hookunt,filetranunt,avunt;

type
  Tudpcore = class(TDataModule)
    udpmsg: TIdUDPServer;
    Freeze: TIdAntiFreeze;
    main_small_list: TImageList;
    events: TApplicationEvents;
    myfont: TFontDialog;
    tempfont: TFontDialog;
    systray: TImageList;
    SysHotKey: TSysHotKey;
    skinimg: TImageList;
    procedure DataModuleCreate(Sender: TObject);
    procedure DataModuleDestroy(Sender: TObject);
    procedure eventsException(Sender: TObject; E: Exception);
    procedure udpmsgUDPRead(Sender: TObject; AData: TStream;
      ABinding: TIdSocketHandle);
    procedure SysHotKeyHotKey(Sender: TObject; Index: Integer);
  private
    pubbitmap:tbitmap; 
    { Private declarations }
//------------------------------------------------------------------------------
    procedure reghotkey(s1:string;s2:integer);
//------------------------------------------------------------------------------
  public
    video_dx9:Tvideo;
    audio_dx9:Taudio;
    plug:Tplug;
    pic:tpic;
    user:Tuser;
    chat:Tchat;
    hook:Thook;
    task:Ttask;
    { Public declarations }
//------------------------------------------------------------------------------
    procedure recreate_hotkey;
    procedure formonpaint(sender:tform);
    procedure changeskin;
    procedure changeLayered(hand:hwnd);
//------------------------------------------------------------------------------
    procedure showfirendinfo(userid:string);
    procedure showprompt(title,s:string);overload;
    procedure showprompt;overload;
    procedure showmsgfrm(s:string);overload;
    procedure showmsgfrm;overload;
    procedure showmsgfrm(s:string;bool:boolean);overload;
    procedure createdlgform(firendid:string);overload;
    procedure createdlgform;overload;
    procedure createhisform(firendid:string);overload;
    procedure createhisform;overload;
    procedure createbroadcastfrm;overload;
    procedure createbroadcastfrm(firendid:string);overload;
    procedure createtaskmainfrm;
//------------------------------------------------------------------------------
    procedure openudport;
    procedure sendtoip(ip:string;port:integer;params:string); overload;
    procedure sendtoip(ip:string;port:string;params:string); overload;
    procedure sendtoip(ip,params:string);overload;
    procedure sendtoipex(ip,port,params:String);
    procedure sendtouser(userid,params:string);overload;
    procedure sendtomessager(firendid,params:string);
//------------------------------------------------------------------------------
    procedure sendbroadcast(port:integer;params:String); overload;
    procedure sendbroadcast(params:String); overload;
    procedure sendbroadcast(bool:boolean;params:String); overload;
//------------------------------------------------------------------------------
    procedure finderuser(ip:string);
    procedure query_firend_status(v:integer);
//------------------------------------------------------------------------------
    procedure sendmutilfile(userlist:string);
    procedure senddirectory(userlist:string);
    procedure sendfileprocess(userlist,filelist,srcpath:string);
    procedure createfiletranfrom(firendid,filelist,srcpath:string);overload;
    procedure createfiletranfrom(params:string);overload;
    procedure checkfiletran;
//------------------------------------------------------------------------------
    procedure createavfrom(firendid:string);
    procedure createavfromex(params:string);
    procedure checkmedia;
//------------------------------------------------------------------------------
    procedure process_tasklist(Tmp:ttaskinfo);
//------------------------------------------------------------------------------
    procedure createremotesvrfrm(firendid:String);
    procedure createremotesvrfrmex(params:String);
    procedure checkremote;
  end;

var
  udpcore: Tudpcore;
implementation
uses shareunit,reginfor,myfirendinfor,promptunt,admsgunt,model,
     usermodel,messagemodel,gamemodel,downpicmodel,filemodel,mediamodel,remotemodel,
     dialogunt,talkrecunt,historyunt,broadcastunt,taskmainunt,remotesvrunt,remotecltunt;
     
{$R *.DFM}
{$R hand.RES}
//------------------------------------------------------------------------------
// 渲染窗体
//------------------------------------------------------------------------------
//function SetLayeredWindowAttributes(hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall; external user32;//函数声明

procedure Tudpcore.changeLayered(hand:hwnd);
Type TMyFunc=function (hwnd:HWND; crKey:Longint; bAlpha:byte; dwFlags:longint ):longint; stdcall;
var n:longint;
    MyFunc: TMyFunc;
    FuncPtr: TFarProc;
    DLLHandle: THandle;
begin
if isnt then
  begin
  n:=getWindowLong(hand, GWL_EXSTYLE);
  n := n Or $80000;
  SetWindowLong (hand, GWL_EXSTYLE, n);

  DLLHandle:= GetModuleHandle(PChar('user32.dll'));
  FuncPtr:= GetProcAddress(DLLHandle, 'SetLayeredWindowAttributes');
  if FuncPtr <> NIL then
      begin
      @MyFunc:= FuncPtr;
      MyFunc(hand, 0, skinclarity, 2);
      end;
  //FreeLibrary(DLLHandle);
  //SetLayeredWindowAttributes(hand, 0, skinclarity, 2);
  end;
end;

procedure Tudpcore.formonpaint(sender:tform);
var rect:trect;
begin
rect.Left:=0; rect.top:=0;
rect.Right:=sender.Width;
rect.Bottom:=sender.Height;
sender.canvas.StretchDraw(rect,pubbitmap);
changeLayered(sender.handle);
end;

procedure Tudpcore.changeskin;
begin
inc(skinindex);
if skinindex>2 then skinindex:=0;
skinimg.GetBitmap(skinindex,pubbitmap);
end;
//------------------------------------------------------------------------------
// 显示好友的资料
//------------------------------------------------------------------------------
procedure Tudpcore.showfirendinfo(userid:string);
begin
with Tmyfirend_infor.create(application) do
  try
  firendid:=userid;
  showmodal;
  finally
  free;
  end;
end;

//------------------------------------------------------------------------------
// 消息广播窗口
//------------------------------------------------------------------------------
procedure Tudpcore.createbroadcastfrm;
begin
with Tbroadcastfrm.create(application) do
  try
  Operation:='Broadcast';
  showmodal;
  finally
  free;
  end;
end;

procedure Tudpcore.createbroadcastfrm(firendid:string);
begin
with Tbroadcastfrm.create(application) do
  try
  md5name:=firendid;
  Operation:='Messenger';
  showmodal;
  finally
  free;
  end;
end;

//------------------------------------------------------------------------------
// 弹出提示窗口
//------------------------------------------------------------------------------
procedure Tudpcore.showprompt(title,s:string);
var promptfrm:tpromptfrm;
begin
SetForegroundWindow(main_hwnd);
promptfrm:=Tpromptfrm.create(application);
promptfrm.caption:=title;
promptfrm.params:=s;
promptfrm.show;
end;

procedure Tudpcore.showprompt;
var params:string;i:integer;
begin
if expandmemo.Count>0 then
   begin
    for i:=expandmemo.Count downto 1 do
       begin
       params:=expandmemo.Strings[i-1];
       if getparamitem(params,'msgid')=inttostr(xy_showpromptform) then
          begin
          expandmemo.Delete(i-1);
          showprompt(getparamitem(params,'msgtext'),getparamitem(params,'paramsex'));
          end;
       end;
   end;
end;

procedure Tudpcore.showmsgfrm(s:string;bool:boolean);
var admsgfrm:Tadmsgfrm;
begin
SetForegroundWindow(main_hwnd);
admsgfrm:=Tadmsgfrm.Create(application);
admsgfrm.autoclose:=bool;
admsgfrm.Msgtxts.Caption:='  '+s;
admsgfrm.show;
end;

procedure Tudpcore.showmsgfrm(s:string);
begin
showmsgfrm(s,true);
end;

procedure Tudpcore.showmsgfrm;
var params:string;i:integer;
begin
if expandmemo.Count>0 then
   begin
    for i:=expandmemo.Count downto 1 do
       begin
       params:=expandmemo.Strings[i-1];
       if getparamitem(params,'msgid')=inttostr(xy_showadmsgform) then
          begin
          expandmemo.Delete(i-1);
          showmsgfrm(getparamitem(params,'msgtext'),
                     getparamitem(params,'autoclose')=inttostr(xy_true));
          end;
       end;
   end;
end;

//------------------------------------------------------------------------------
// 建立聊天窗口
//------------------------------------------------------------------------------
procedure Tudpcore.createdlgform(firendid:string);
var dialogfrm:Tdialogfrm;
    tmp:userinfo;
begin
if user.checkuser(firendid) then
  begin
  tmp:=user.getuserinfoex(firendid);
  if tmp.dlghwnd=0 then
    begin
    dialogfrm:=Tdialogfrm.create(application);
    tmp.dlghwnd:=dialogfrm.Handle;
    tmp.dx:=dialogfrm.Left;
    tmp.dy:=dialogfrm.top;
    tmp.dw:=dialogfrm.width;
    user.modifyuser(firendid,tmp);
    dialogfrm.firendid:=firendid;
    dialogfrm.show;
    end;
  end;
end;

procedure Tudpcore.createdlgform;
var params:string;i:integer;
begin
if expandmemo.Count>0 then
   begin
    for i:=expandmemo.Count downto 1 do
       begin
       params:=expandmemo.Strings[i-1];
       if getparamitem(params,'msgid')=inttostr(xy_createdlgform) then
          begin
          expandmemo.Delete(i-1);
          createdlgform(getparamitem(params,'firendid'));
          end;
       end;
   end;
end;

procedure Tudpcore.createhisform(firendid:string);
var talkrecfrm:Ttalkrecfrm;
    tmp:userinfo;
begin
if user.checkuser(firendid) then
    begin
    tmp:=user.getuserinfoex(firendid);
    talkrecfrm:=Ttalkrecfrm.create(application);
    tmp.hishwnd:=talkrecfrm.Handle;
    user.modifyuser(firendid,tmp);
    talkrecfrm.firendid:=firendid;
    talkrecfrm.left:=tmp.dx;
    talkrecfrm.Top:=tmp.dy+1;
    talkrecfrm.width:=tmp.dw;
    talkrecfrm.show;
    end;
end;

procedure Tudpcore.createhisform;
begin
with Thistoryfrm.create(application) do
  try
  showmodal;
  finally
  free;
  end;
end;

//------------------------------------------------------------------------------
// 初始化通讯端口
//------------------------------------------------------------------------------
procedure Tudpcore.openudport;
begin
try
udpmsg.DefaultPort:=core_port;
udpmsg.Bindings.Clear;
with udpmsg.Bindings.Add do
 begin
 ip:='0.0.0.0';
 Port:=core_port;
 end;
udpmsg.Active:=true;
except
showmessage('启动程序出错,初始化端口失败'+' 端口:'+inttostr(core_port));
end;

end;

//------------------------------------------------------------------------------
// 软件开始运行的初始化
//------------------------------------------------------------------------------
procedure Tudpcore.DataModuleCreate(Sender: TObject);
begin
try
mylocalip:=localip;
mycomputername:=localname;
application_name:=application.ExeName;
Screen.Cursors[crHandPoint]:= LoadCursor(Hinstance,'MYHAND');
SetWindowLong(Application.Handle, GWL_EXSTYLE, WS_EX_TOOLWINDOW);
readini;
readhistoryiplist;
video_dx9:=Tvideo.create;
audio_dx9:=Taudio.create;
user:=Tuser.create;
plug:=tplug.create;
pic:=tpic.create;
chat:=Tchat.create;
hook:=Thook.create;
task:=Ttask.create;
pubbitmap:=Tbitmap.Create;
skinimg.GetBitmap(skinindex,pubbitmap);
finally
application.ProcessMessages;
end;
end;

//------------------------------------------------------------------------------
// 软件结束运行的释放
//------------------------------------------------------------------------------
procedure Tudpcore.DataModuleDestroy(Sender: TObject);
begin
video_dx9.Free;
audio_dx9.free;
plug.free;
pic.free;
user.free;
chat.free;
hook.free;
task.free;
pubbitmap.free;
writeini;
Reg_autorun;
end;

//------------------------------------------------------------------------------
//  记录异常错误
//------------------------------------------------------------------------------
procedure Tudpcore.eventsException(Sender: TObject;
  E: Exception);
begin
logmemo.add(timetostr(time)+':'+e.Message);
end;
//------------------------------------------------------------------------------
// 发送消息到指定用户
//------------------------------------------------------------------------------
procedure tudpcore.sendtoip(ip:string;port:integer;params:string);
begin
makeparamsex(params,'language',locallanguage);
encompress(params);//压缩
if checkip(ip) then
   udpmsg.Binding.SendTo(ip,port,params[1],length(params));
sleep(1);
end;

procedure tudpcore.sendtoip(ip:string;port:string;params:string);
begin
sendtoip(ip,strtoint(port),params);
end;

procedure tudpcore.sendtoip(ip,params:string);
begin
sendtoip(ip,core_port,params);
end;

procedure tudpcore.sendtouser(userid,params:string);
var tmp:userinfo;
begin
if user.checkuser(userid) then
   begin
   tmp:=user.getuserinfoex(userid);
   if tmp.status<>3 then  //如果对方不在线就放入计划任务内
      sendtoip(tmp.localip,core_port,params)
      else task.addtask(nowtimedefer(15),userid,params,false);
   end;
end;

//------------------------------------------------------------------------------
// 例外的未经加密的发送函数
//------------------------------------------------------------------------------
procedure tudpcore.sendtoipex(ip,port,params:String);
begin
udpmsg.Binding.SendTo(ip,strtoint(port),params[1],length(params));
sleep(1);
end;
//------------------------------------------------------------------------------
// 发送广播
//------------------------------------------------------------------------------
procedure tudpcore.sendbroadcast(port:integer;params:String);
begin
makeparamsex(params,'language',locallanguage);
encompress(params);//压缩
udpmsg.Broadcast(params,port);
sleep(1);
end;

procedure tudpcore.sendbroadcast(params:String);
begin
sendbroadcast(core_port,params);
end;

procedure tudpcore.sendbroadcast(bool:boolean;params:String);
var i:integer;
    tmp:userinfo;
begin
if user.getcount>0 then
for i:=user.getcount downto 2 do
  begin
  tmp:=user.getuserinfoex(i-1);
  if (not tmp.nullity)and(checkip(tmp.localip)) then
     begin
     if bool then
        begin
        if tmp.status<3 then
           sendtoip(tmp.localip,params);
        end else begin
        sendtomessager(tmp.md5name,params);
        end;
     application.ProcessMessages;
     end;
  end;
end;