Delphi 局域网点对点文件传输(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.