filetranunt.pas

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

unit filetranunt;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms,dialogs,
  xpButton, StdCtrls, Gauges, IdBaseComponent,ComCtrls,ExtCtrls,
  IdComponent, IdUDPBase, IdUDPServer,IdSocketHandle, IdAntiFreezeBase,
  IdAntiFreeze,constunt,structureunt,compress;

type
  Tfiletranfrm = class(TForm)
    trans_status_label: TLabel;
    Bevel1: TBevel;
    Bevel3: TBevel;
    Label2: TLabel;
    Label3: TLabel;
    Label1: TLabel;
    maxbar: TGauge;
    minbar: TGauge;
    StatusBar1: TStatusBar;
    Edit1: TEdit;
    okbtn: TxpButton;
    cancelbtn: TxpButton;
    UDPServer: TIdUDPServer;
    AntiFreeze: TIdAntiFreeze;
    Label4: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure okbtnClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure cancelbtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
  private
    start_time:tdatetime;
    status_array:array of Byte;            //文件分块状态数组  0:none 1:request 2:complete
    cur_filename:string;   //当前正在传输的文件名称..
    filelist_position,                     //当前文件的在所有列表中的位置
    cur_completecount,                     //当前文件完成数量.
    cur_filesize:integer;                  //当前文件的大小
    just_trans_files,                       //正在传输
    succeedconnect,                       //连接已经建立.
    filetran_complete:boolean;
    total_trans_packet:int64;              //总传输数据包
    //  服务端 也就是发送文件的那一端
    procedure UDPServerUDPRead(Sender: TObject; AData: TStream;ABinding: TIdSocketHandle);
    //  客户端 接收文件端.
    procedure UDPClientUDPRead(Sender: TObject; AData: TStream;ABinding: TIdSocketHandle);
    //--------------------------------------------------------------------------
    procedure handshake(msgid:integer);  //简单命令交互
    //处理自定义消息.
    procedure process_custom_message(var msg:tmessage);message refresh_status;
    //(如果文件存在) 重建文件分块的标志数组
    procedure rebuild_file_array;
    //从标志数组中返回最近一个的没有标志的数组id
    function getnextposition:integer;

    procedure refresh_trans_infor;
    //--------------------------------------------------------------------------
    //发送消息
    procedure sendmsgto(msg:string);
    //发送文件的信息到客户端
    procedure sendtoclient_fileinfor;
    //处理收到的文件信息
    procedure inceptserver_fileinfor(datstr:string);
    procedure send_reqeust_thread(id:integer);
    //开始请求 当前要传输的文件块.
    procedure startrequestsend_data;
    //发送客户端请求的文件块
    procedure startsendtoclient_data(infor:Tdatapack;datstr:string);
    //处理收到的文件块..
    procedure process_client_data(infor:Tdatapack;datstr:string);
    { Private declarations }
  public
    Fserver:boolean;                           //标志模式
    svrport,destport:integer;                         //对方的端口
    svrip,destip:string;                            //对方的IP

    source_path,                               //源路径
    dest_path:string;                          //目录路径

    filelist:tstringlist;                      //所有要传输的文件列表
    procedure initfiletran;
    procedure sendmsgtosvr(msg:string);
    { Public declarations }
  end;

implementation
uses shareunit, udpcores;
{$R *.DFM}

//******************************************************************************
//窗体建立
procedure Tfiletranfrm.FormCreate(Sender: TObject);
begin
addhwnd(handle);
udpcore.changeLayered(handle);
filelist:=tstringlist.create;
end;

//窗体显示
procedure Tfiletranfrm.FormShow(Sender: TObject);
begin
if not Fserver then
   begin
   succeedconnect:=true;
   handshake(xy_first_handshake);//确认连接
   end;
end;

//窗体关闭
procedure Tfiletranfrm.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
delhwnd(handle);
if not filetran_complete then
   begin
   if just_trans_files then handshake(xy_cancel);
   if not just_trans_files then
      if Fserver then handshake(xy_cancel) else handshake(xy_refuseing);
   end else begin
   if (not Fserver)and(not just_trans_files) then
      udpcore.showmsgfrm('文件接收完成',not autoaccept_file);
   end;
udpserver.Active:=false;
status_array:=nil;
freeandnil(filelist);
Action:=cafree;
Tfiletranfrm(sender):=nil;
end;

//窗体 构析
procedure Tfiletranfrm.okbtnClick(Sender: TObject);
var path:string;
begin
//开始请求文件传送...
{1.请求路径,文件总数,当前文件序号,当前文件名称,当前文件大小}
if selectpath(path) then
   begin
   autopath:=path;
   dest_path:=path;
   end;

okbtn.Enabled:=false;
start_time:=time;
just_trans_files:=true;
handshake(xy_infor);
end;


procedure Tfiletranfrm.cancelbtnClick(Sender: TObject);
begin
close;
end;

//******************************************************************************
//消息发送
//******************************************************************************
procedure Tfiletranfrm.sendmsgto(msg:string);
begin
if succeedconnect then 
udpserver.Binding.SendTo(destip,destport,msg[1],length(msg));
sleep(1);
end;

//------------------------------------------------------------------------------
// 与中转服务器进行协商
//------------------------------------------------------------------------------
procedure Tfiletranfrm.sendmsgtosvr(msg:string);
begin
makeparamsex(msg,'language',locallanguage);
encompress(msg);//压缩
udpserver.Binding.SendTo(svrip,svrport,msg[1],length(msg));
sleep(1);
end;

//******************************************************************************
// 简单命令交互
//******************************************************************************
procedure Tfiletranfrm.handshake(msgid:integer);
begin
sendmsgto(makepacket(msgid,0,0));
end;
//******************************************************************************

procedure Tfiletranfrm.initfiletran;
begin
udpserver.Bindings.clear;
with udpserver.Bindings.add do
  begin
  ip:='0.0.0.0';
  port:=0;
  end;
udpserver.Active:=true;
udpserver.Binding.UpdateBindingLocal;
if not Fserver then
   begin
   Label1.caption:='发送给:';
   udpserver.OnUDPRead:=UDPClientUDPRead;
   end else begin
   okbtn.Enabled:=false;
   Label1.caption:='接收至:';
   udpserver.OnUDPRead:=UDPServerUDPRead;
   end;
end;

//******************************************************************************
//接收端处理过程
//******************************************************************************
procedure Tfiletranfrm.UDPServerUDPRead(Sender: TObject; AData: TStream;ABinding: TIdSocketHandle);
var datastr:string;
    tmpack:Tdatapack;
begin
try
adata.Seek(0,soFromBeginning);
setlength(datastr,adata.size-sizeof(Tdatapack));
adata.ReadBuffer(tmpack,sizeof(Tdatapack)); //取出msgid 和 position
adata.ReadBuffer(datastr[1],adata.size-sizeof(Tdatapack)); //取出 msgtext

case tmpack.msgid of
  xy_first_handshake:
     begin
     destip:=ABinding.PeerIP;
     destport:=ABinding.PeerPort;
     succeedconnect:=true;
     handshake(xy_succeed_handshake);
     //开始等待文件传送...
     end;
     
  xy_infor:
     begin
     if not just_trans_files then start_time:=time;
     just_trans_files:=true;
     {1.请求路径,文件总数,当前文件序号,当前文件名称,当前文件大小
        返回给客户端 1}
     sendtoclient_fileinfor;
     end;

  xy_detail:
     begin
     trans_status_label.caption:='正在发送...';
     {2.开始请求传输文件内容
        返回给客户端}
     startsendtoclient_data(tmpack,datastr);
     end;

  xy_cancel:
     begin
     just_trans_files:=false;
     postmessage(handle,refresh_status,xy_cancel,0);
     postmessage(handle,refresh_status,xy_filetran_complete,0);
     end;

  xy_refuseing:
     begin
     //对方拒绝
     postmessage(handle,refresh_status,xy_refuseing,0);
     postmessage(handle,refresh_status,xy_filetran_complete,0);
     end;
  end;

except

end;
end;

//******************************************************************************
//发送端处理过程
//******************************************************************************
procedure Tfiletranfrm.UDPClientUDPRead(Sender: TObject; AData: TStream;ABinding: TIdSocketHandle);
var datastr:string;
    tmpack:Tdatapack;