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


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.


联系电话:
020-00000000
联系电话:
020-00000000
联系电话:
020-12345678