unit Unit1; interface uses Windows, Messages, SysUtils, Variants,"/> unit Unit1; interface uses Windows, Messages, SysUtils, Variants,"/>
爱资料logo
主页 > 编程资料 > Delphi >

Delphi 局域网点对点文件传输(IdTcpClient控件)

发布时间：2015-09-22 作者：网络 阅读：149次


 

Delphi <wbr>局域网点对点文件传输(IdTcpClient控件)

 

 

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls, ScktComp, IdTCPServer,
 IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient;

type
 TForm1 = class(TForm)
   Panel1: TPanel;
   Panel2: TPanel;
   SpeedButton1: TSpeedButton;
   SpeedButton2: TSpeedButton;
   SpeedButton3: TSpeedButton;
   LBFiles: TLabel;
   SpeedButton4: TSpeedButton;
   SpeedButton5: TSpeedButton;
   OpenDialog1: TOpenDialog;
   SaveDialog1: TSaveDialog;
   PB2: TProgressBar;
   PB1: TProgressBar;
   ListBox1: TListBox;
   Label2: TLabel;
   IdTCPClient1: TIdTCPClient;
   IdTCPServer1: TIdTCPServer;
   LBSend: TLabel;
   Edit1: TEdit;
   Label1: TLabel;
   IdTCPClient2: TIdTCPClient;
   IdTCPServer2: TIdTCPServer;
   procedure SpeedButton1Click(Sender: TObject);
   procedure ListBox1DblClick(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure SpeedButton2Click(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure SpeedButton4Click(Sender: TObject);
   procedure IdTCPServer1Execute(AThread: TIdPeerThread);
   procedure SpeedButton5Click(Sender: TObject);
   procedure SpeedButton3Click(Sender: TObject);
   procedure IdTCPServer2Connect(AThread: TIdPeerThread);
   procedure IdTCPServer2Execute(AThread: TIdPeerThread);
 private
   { Private declarations }
 public
   Function Act_DownFiles(CurFilePath,SerFilePath,CurFileName,SerFileName:String):Boolean;
 end;

var
 Form1: TForm1;
 UserName:String;
 RecivList:TStrings;
 SendIP:String;
 DownFlag:Boolean;
implementation

{$R *.dfm}

procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
 if OpenDialog1.Execute then
 begin
   if ListBox1.Items.IndexOf(OpenDialog1.FileName) = -1 then
   begin
     ListBox1.Items.Add(OpenDialog1.FileName);
   end;
 end;
 
end;

procedure TForm1.ListBox1DblClick(Sender: TObject);
begin
 if ListBox1.ItemIndex >=0 then
   ListBox1.Items.Delete(ListBox1.ItemIndex);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 self.Height:=267;
 IdTCPServer2.Active:=True;
 IdTCPServer1.Active:=True;
 UserName:='admin';
 RecivList:=TStringList.Create;
 DownFlag:=True;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
var
 TemFiles:String;
begin

 if ListBox1.Count > 0 then
 begin
   SpeedButton2.Enabled:=False;
   
   TemFiles:=ListBox1.Items.CommaText;

   IdTCPClient2.Host :=Trim(Edit1.Text);//服务器的地址

   if IdTCPClient2.Connected then
     IdTCPClient2.Disconnect;

   Try
     IdTCPClient2.Connect;
   except
     MessageBox(Handle,'服务器没有开启','提示',MB_OK);
     Exit;
   end;

   with  IdTCPClient2  do
   begin
     while  Connected  do
     begin
       try
         WriteLn('SendFiles#'+ListBox1.Items.CommaText+'%'+UserName); //指定路径
       finally
         Disconnect;//断开连接
       end;
     end;
   end;


 end
 else
 begin
   MessageBox(Handle,'请选择要传送的文件','提示',MB_OK);
 end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 RecivList.Free;
end;

procedure TForm1.SpeedButton4Click(Sender: TObject);
var
 CurFilePath,SerFilePath:String;
 FileName,TemStr:String;
 i,TemInt:integer;
begin
 SpeedButton4.Enabled:=False;
 
 DownFlag:=True;
 TemStr:='';
 TemInt:=0;

 if SaveDialog1.Execute then
 begin
   CurFilePath:=ExtractFilePath(SaveDialog1.FileName);

   for i:=0 to RecivList.Count - 1 do
   begin
     SerFilePath:=ExtractFilePath(RecivList.Strings[i]);
     FileName:=ExtractFileName(RecivList.Strings[i]);

     if not Act_DownFiles(CurFilePath,SerFilePath,FileName,FileName) then
     begin
       TemInt:=TemInt+1;
       TemStr:=TemStr+ FileName;
     end;
   end;

   if TemInt > 0 then
   begin
     MessageBox(Handle,PChar(TemStr+'文件没有传输成功'),'提示',MB_OK);
   end
   else
   begin
     MessageBox(Handle,'所有文件传输成功','提示',MB_OK);
   end;

   IdTCPClient1.Host :=SendIP;
   
   if IdTCPClient1.Connected then
     IdTCPClient1.Disconnect;

   Try
     IdTCPClient1.Connect;
   except
     MessageBox(Handle,'服务器没有开启','提示',MB_OK);
     Exit;
   end;

   with  IdTCPClient1  do
   begin
     while  Connected  do
     begin
       try
         WriteLn('OK'); //指定路径
       finally
         Disconnect;//断开连接
       end;
     end;
   end;

   Close;
 end;
end;

Function TForm1.Act_DownFiles(CurFilePath,SerFilePath,CurFileName,SerFileName:String):Boolean;
var
 TemFileName:String;
 rbyte:array[0..4096] of byte;
 sFile:TFileStream;
 iFileSize:integer;
begin
 PB1.Position:=0;
 IdTCPClient1.Host :=SendIP;//服务器的地址

 if IdTCPClient1.Connected then
   IdTCPClient1.Disconnect;

 Try
   IdTCPClient1.Connect;
 except
   MessageBox(Handle,'服务器没有开启','提示',MB_OK);
   Result:=False;
   Exit;
 end;

 with  IdTCPClient1  do
 begin
   while  Connected  do
   begin
     try
       TemFileName:=SerFilePath+SerFileName;
       WriteLn(TemFileName); //指定路径

       if ReadLn<>'文件不存在' then
       begin
         iFileSize:=IdTCPClient1.ReadInteger;
         PB1.Max := iFileSize div 100 ;
         sFile:=TFileStream.Create(CurFilePath+CurFileName,fmCreate);

         While iFileSize>4096 do
         begin
           if DownFlag then
           begin
             IdTCPClient1.ReadBuffer(rbyte,4096);// .ReadBuffer(rbyte,iLen);
             sFile.Write(rByte,4096);
             inc(iFileSize,-4096);
             PB1.Position:= PB1.Position +(4096 div 100) ;

             Application.ProcessMessages;
           end
           else
           begin
             Result:=False;
             Exit;
           end;
         end;

         IdTCPClient1.ReadBuffer(rbyte,iFileSize);// .ReadBuffer(rbyte,iLen);

         sFile.Write(rByte,iFileSize);
         sFile.Free;

         PB1.Position:=PB1.Max;
       end;

     finally
       Disconnect;//断开连接
     end;
   end;
 end;
 Result:=True;
end;

procedure TForm1.IdTCPServer1Execute(AThread: TIdPeerThread);
var
 RecevFileName:string;
 iFileHandle:integer;
 iFileLen,cnt:integer;
 buf:array[0..4096] of byte;
begin
 if not AThread.Terminated and AThread.Connection.Connected then //注意这里
 begin
   with  AThread.Connection  do
   begin
     Try
       RecevFileName:=AThread.Connection.ReadLn;

       if RecevFileName='OK' then
       begin
         PB2.Position:=0;
         LBSend.Caption:='All Files Send OK';
       end;

       if RecevFileName='RefusedAll' then
       begin
         LBSend.Caption:='All Files are Refused';
         PB2.Position:=0;
       end;

       if (RecevFileName<>'OK') and (RecevFileName<>'RefusedAll') then
       begin
         if FileExists(RecevFileName) then
         begin
           PB2.Position:=0;

           WriteLn(RecevFileName);

           LBSend.Caption:='Send: '+RecevFileName;

           iFileHandle:=FileOpen(RecevFileName,fmOpenRead); //得到此文件大小
           iFileLen:=FileSeek(iFileHandle,0,2);

           FileSeek(iFileHandle,0,0);
           AThread.Connection.WriteInteger(iFileLen,True);////hjh 20071009

           PB2.Max := iFileLen div 100 ;
         
           while iFileLen >0 do
           begin
             cnt:=FileRead(iFileHandle,buf,4096);
             AThread.Connection.WriteBuffer(buf,cnt,True);/////hjh20071009
             iFileLen:=iFileLen-cnt;
             PB2.Position:=PB2.Position +(4096 div 100) ;
             Application.ProcessMessages;
           end;

           FileClose(iFileHandle);
         end
         else
         begin
           WriteLn('文件不存在');
         end;
       end;
     Finally
       Disconnect;//断开连接
     end;
   end;
 end;
end;

procedure TForm1.SpeedButton5Click(Sender: TObject);
var
 i:integer;
begin
 DownFlag:=False;

 IdTCPClient1.Host :=SendIP;//服务器的地址

 if IdTCPClient1.Connected then
   IdTCPClient1.Disconnect;

 Try
   IdTCPClient1.Connect;
 except
   MessageBox(Handle,'服务器没有开启','提示',MB_OK);
   Exit;
 end;

 with  IdTCPClient1  do
 begin
   while  Connected  do
   begin
     try

       WriteLn('RefusedAll'); //指定路径

     finally
       Disconnect;//断开连接
     end;
   end;
 end;

 IdTCpClient1.Disconnect;

 //Application.Terminate;
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
var
 TemStr:String;
begin
 if Trim(LBSend.Caption)='' then
 begin
   Close;
 end;

 if Trim(LBSend.Caption)='All Files Send OK' then
 begin
   Close;
 end
 else
 begin
   PB2.Position:=0;

   IdTCPClient2.Host :=Trim(Edit1.Text);//服务器的地址

   if IdTCPClient2.Connected then
     IdTCPClient2.Disconnect;

   Try
     IdTCPClient2.Connect;
   except
     MessageBox(Handle,'服务器没有开启','提示',MB_OK);
     Exit;
   end;

   with  IdTCPClient2  do
   begin
     while  Connected  do
     begin
       try
         WriteLn('RefuseSend'); //指定路径

       finally
         Disconnect;//断开连接
       end;
     end;
   end;
   
 end;
 
end;

procedure TForm1.IdTCPServer2Connect(AThread: TIdPeerThread);
begin
 SendIP:=AThread.Connection.Socket.Binding.PeerIP;
 
end;

procedure TForm1.IdTCPServer2Execute(AThread: TIdPeerThread);
var
 RecivStr,FileStr:String;
 TemList:TStrings;
 TemUser:String;
 i:integer;
begin
 if not AThread.Terminated and AThread.Connection.Connected then //注意这里
 begin
   with  AThread.Connection  do
   begin
     Try

       FileStr:='';
       RecivStr:=ReadLn;

       if RecivStr <>'RefuseSend' then
       begin
         if Pos('SendFiles',RecivStr) > 0 then
         begin
           Self.Height:=130;
           Panel1.Visible:=False;
           RecivList.Clear;

           RecivList.CommaText:=Copy(RecivStr,Pos('#',RecivStr)+1,Pos('%',RecivStr)-Pos('#',RecivStr)-1);
           TemUser:=Copy(RecivStr,Pos('%',RecivStr)+1,Length(RecivStr)-Pos('%',RecivStr));

           for i:=0 to RecivList.Count -1 do
           begin
             FileStr:=FileStr+ExtractFileName(RecivList.Strings[i])+',';
           end;

           LBFiles.Caption:=TemUser+' 向您发送文件:'+FileStr+'请接收';
         end;
       end;

       if RecivStr='RefuseSend' then
       begin
         LBFiles.Caption:='对方取消了发送文件';
         PB1.Position:=0;
         DownFlag:=False;
       end;

     Finally
       Disconnect;
     end;
   end;
 end;

end;

end.


关键字词:

相关文章

栏目导航

最新文章

点击排行

推荐文章

打赏

weixin alipay


Copyright ©2014 apizl.com    粤ICP备15076105号-1   本站运行: 3782天
网页模板、字体、软件、资料、资源部分是从国外大小网站收集而来，为朋友们在工作或学习时提高效率、节省时间.
站内所有资源仅供学习与参考，请勿用于商业用途，否则产生的一切后果将由您自己承担！