unit1.pas

Dephi实现的ftp传输软件

{
 ********FTP传输工具********
 ********设计：孔勇*********
 ********2005.3.15**********
 *********凯科软件**********
}
unit Unit1; 

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, ComCtrls, StdCtrls, Buttons, IdAntiFreezeBase,
  IdAntiFreeze, IdBaseComponent, IdIntercept, IdLogBase, IdLogDebug,
  IdComponent, IdTCPConnection, IdTCPClient, IdFTP;

type
   TForm1 = class(TForm)
    StatusBar1: TStatusBar;
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    TabSheet3: TTabSheet;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Button1: TButton;
    Button2: TButton;
    GroupBox1: TGroupBox;
    GroupBox2: TGroupBox;
    Label5: TLabel;
    Edit5: TEdit;
    SpeedButton1: TSpeedButton;
    Label6: TLabel;
    Edit6: TEdit;
    SpeedButton2: TSpeedButton;
    ListBox1: TListBox;
    ListBox2: TListBox;
    SpeedButton3: TSpeedButton;
    SpeedButton4: TSpeedButton;
    SpeedButton5: TSpeedButton;
    SpeedButton6: TSpeedButton;
    SpeedButton7: TSpeedButton;
    SpeedButton8: TSpeedButton;
    SpeedButton9: TSpeedButton;
    SpeedButton10: TSpeedButton;
    Image1: TImage;
    Label7: TLabel;
    Label20: TLabel;
    Label21: TLabel;
    Label22: TLabel;
    Bevel1: TBevel;
    Label23: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    ListBox3: TListBox;
    CheckBox1: TCheckBox;
    Panel1: TPanel;
    ProgressBar1: TProgressBar;
    ProgressLbl: TLabel;
    IdLogDebug1: TIdLogDebug;
    IdAntiFreeze1: TIdAntiFreeze;
    IdFTP1: TIdFTP;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton3Click(Sender: TObject);
    procedure SpeedButton4Click(Sender: TObject);
    procedure SpeedButton5Click(Sender: TObject);
    procedure SpeedButton6Click(Sender: TObject);
    procedure SpeedButton7Click(Sender: TObject);
    procedure SpeedButton8Click(Sender: TObject);
    procedure SpeedButton9Click(Sender: TObject);
    procedure SpeedButton10Click(Sender: TObject);
    procedure ListBox2Click(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure IdFTP1Disconnected(Sender: TObject);
    procedure IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
      const asStatusText: String);
    procedure IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);
    procedure IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
    procedure IdLogDebug1LogItem(ASender: TComponent; var AText: String);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    AbortTransfer: Boolean;
    TransferrignData: Boolean;
    BytesToTransfer: LongWord;
    STime: TDateTime;
    procedure GetDir(DirName: String);
    procedure GetFileList(FileSpec:string;NamesOnly:Boolean;FileList: TStrings);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  AverageSpeed: Double = 0;
  i,j:Integer;

implementation

{$R *.dfm}

uses
  FileCtrl, piStrCrypt, IdFTPCommon{定义:ftASCII,ftBinary};

procedure TForm1.GetDir(DirName: String);
begin
  try
    IdFTP1.ChangeDir(DirName);
    IdFTP1.TransferType:=ftASCII;
    Edit6.Text := IdFTP1.RetrieveCurrentDir;
    ListBox2.Items.Clear;
    IdFTP1.List(ListBox2.Items,'',false);//列出文件和目录
  finally
    //
  end;
end;

procedure TForm1.GetFileList(FileSpec:string;NamesOnly:Boolean;FileList: TStrings);
var
  SR: TSearchRec;
  DosError: integer; 
begin
  FileList.Clear;
  DosError := FindFirst(FileSpec, faAnyFile-faDirectory, SR);
  while DosError=0 do
  begin
   if NamesOnly then 
    FileList.Add(SR.Name)
   else 
    FileList.Add(ExtractFilePath(FileSpec)+SR.Name);
   DosError := FindNext(SR);
  end; 
end; 

procedure TForm1.Button1Click(Sender: TObject);
begin
  try
    IdFTP1.Username := Edit3.Text;
    IdFTP1.Password := Edit4.Text;
    IdFTP1.Host := Edit1.Text;
    IdFTP1.Connect;
    GetDir(Edit6.Text);
  finally
    StatusBar1.SimpleText := '状态：连接成功！';
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  if IdFTP1.Connected then
    try
      if TransferrignData then
         IdFTP1.Abort;
      IdFTP1.Quit;
    finally
      Edit6.Text := '/';
      ListBox2.Items.Clear;
      StatusBar1.SimpleText := '状态：已经断开连接！';
    end
end;

procedure TForm1.SpeedButton1Click(Sender: TObject);
var
 S: string;
begin
 S :='';
 if SelectDirectory('选择目录','', S) then
 begin
  Edit5.Text:=S;
  GetFileList(S+'\*.*',true,ListBox1.Items);
 end;
end;

procedure TForm1.SpeedButton2Click(Sender: TObject);
begin
  GetDir(Edit6.Text);
  Edit6.Text:='/';
end;

procedure TForm1.SpeedButton3Click(Sender: TObject);
var
 NewString: string;
begin
 if InputQuery('文件传输精灵', '请输入目录名：', NewString) then
 begin
  IdFTP1.MakeDir(NewString);
  GetDir(Edit6.Text);
 end;
end;

procedure TForm1.SpeedButton4Click(Sender: TObject);
begin
 IdFTP1.RemoveDir(ListBox2.Items.Strings[j]);
 GetDir(Edit6.Text);
end;

procedure TForm1.SpeedButton5Click(Sender: TObject);
begin
  IdFTP1.TransferType := ftBinary;
  IdFTP1.Put(Edit5.Text+'\'+ListBox1.Items.Strings[i], ListBox1.Items.Strings[i]);
  GetDir(IdFTP1.RetrieveCurrentDir);
end;

procedure TForm1.SpeedButton6Click(Sender: TObject);
begin
  IdFTP1.TransferType := ftBinary;
  BytesToTransfer := IdFTP1.Size(ListBox2.Items.Strings[j]);
  IdFTP1.Get(ListBox2.Items.Strings[j], Edit5.Text+'\'+ListBox2.Items.Strings[j], true);
  GetFileList(Edit5.Text+'\*.*',true,ListBox1.Items);
end;

procedure TForm1.SpeedButton7Click(Sender: TObject);
var
 NewString: string;
begin
 if InputQuery('文件传输精灵', '请输入新的文件名：', NewString) then
 begin
   IdFTP1.Rename(ListBox2.Items.Strings[j],NewString);
   GetDir(Edit6.Text);
 end;
end;

procedure TForm1.SpeedButton8Click(Sender: TObject);
begin
  IdFTP1.Delete(ListBox2.Items.Strings[j]);
  GetDir(IdFTP1.RetrieveCurrentDir);
end;

procedure TForm1.SpeedButton9Click(Sender: TObject);
var
 TemList:TStrings;
 TemStr,NewString:String;
 Tword:Word;
begin
 Temlist:=TStringList.Create;
 Temlist.LoadFromFile(Edit5.Text+'\'+ListBox1.Items.Strings[i]);
 Tword:=123;
 if InputQuery('文件传输精灵', '请输入密码1-5位：', NewString) then
    Tword:=StrToInt(NewString);
 TemStr:=StrEncrypt(Temlist.Text,Tword);
 Temlist.Clear;
 Temlist.Add(TemStr);
 Temlist.SaveToFile(ExtractFilePath(Application.ExeName)+'temp.txt');
 IdFTP1.TransferType := ftBinary;
 IdFTP1.Put(ExtractFilePath(Application.ExeName)+'temp.txt','Mydoc.txt');
 GetDir(IdFTP1.RetrieveCurrentDir);
 Temlist.Free;
end;

procedure TForm1.SpeedButton10Click(Sender: TObject);
var
 TemList:TStrings;
 TemStr,NewString:String;
 Tword:Word;
 fm:TForm;
 memo:TMemo;
begin
 if FileExists(ExtractFilePath(Application.ExeName)+'temp.txt') then
    DeleteFile(ExtractFilePath(Application.ExeName)+'temp.txt');
 IdFTP1.TransferType := ftBinary;
 BytesToTransfer := IdFTP1.Size(ListBox2.Items.Strings[j]);
 IdFTP1.Get('Mydoc.txt',ExtractFilePath(Application.ExeName)+'temp.txt');
 Temlist:=TStringList.Create;
 Temlist.LoadFromFile(ExtractFilePath(Application.ExeName)+'temp.txt');
 Tword:=123;
 if InputQuery('文件传输精灵', '请输入密码：', NewString) then
    Tword:=StrToInt(NewString);
 TemStr:=StrDecrypt(Temlist.Text,Tword);
 Temlist.Free;
 fm:=TForm.Create(Application);
 fm.Height:=450;
 fm.Width:=700;
 fm.Caption:='查看个人资料';
 fm.BorderStyle:=bsDialog;
 fm.Position:=poScreenCenter;
 memo:=TMemo.Create(fm);
 memo.Parent:=fm;
 memo.Align:=alClient;
 memo.ScrollBars:=ssVertical;
 memo.Lines.Text:=TemStr;
 fm.ShowModal;
end;

procedure TForm1.ListBox1Click(Sender: TObject);
begin
 i:=ListBox1.ItemIndex;
end;

procedure TForm1.ListBox2Click(Sender: TObject);
begin
 j:=ListBox2.ItemIndex;
 if AnsiPos('.',ListBox2.Items.Strings[j])=0 then
    Edit6.Text:='/'+ListBox2.Items.Strings[j];
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  IdLogDebug1.Active := true;
end;

procedure TForm1.IdFTP1Disconnected(Sender: TObject);
begin
  StatusBar1.SimpleText := '状态：已经断开连接！';
end;

procedure TForm1.IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
  const asStatusText: String);
begin
  ListBox3.ItemIndex := ListBox3.Items.Add(asStatusText);
end;

procedure TForm1.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCount: Integer);
var
  S: String;
  TotalTime: TDateTime;
  H, M, Sec, MS: Word;
  DLTime: Double;
begin
  TotalTime :=  Now-STime;
  DecodeTime(TotalTime, H, M, Sec, MS);
  Sec := Sec+M*60+H*3600;
  DLTime := Sec+MS/1000;
  if DLTime>0 then
     AverageSpeed := (AWorkCount/1024)/DLTime;
  S := FormatFloat('0.00 KB/s', AverageSpeed);
  case AWorkMode of
    wmRead: StatusBar1.SimpleText := '状态：下载速度  '+S;
    wmWrite: StatusBar1.SimpleText := '状态：上传速度  '+S;
  end;
  if AbortTransfer then
     IdFTP1.Abort;
  ProgressBar1.Position:=AWorkCount;
  ProgressLbl.Caption :='正在传输...  (已完成  '+IntToStr(AWorkCount)+'  字节)';
  Application.ProcessMessages;
  AbortTransfer := false;
end;

procedure TForm1.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
  const AWorkCountMax: Integer);
begin
  Panel1.Visible:=true;
  TransferrignData := true;
  AbortTransfer := false;
  STime := Now;
  if AWorkCountMax > 0 then
     ProgressBar1.Max:=AWorkCountMax
  else
     ProgressBar1.Max:=BytesToTransfer;
  AverageSpeed := 0;
end;

procedure TForm1.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  StatusBar1.SimpleText := '状态：文件传输完毕！';
  Panel1.Visible:=false;
  BytesToTransfer := 0;
  TransferrignData := false;
  AverageSpeed := 0;
end;

procedure TForm1.IdLogDebug1LogItem(ASender: TComponent;
  var AText: String);
begin
  ListBox3.ItemIndex := ListBox3.Items.Add(AText);
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
  IdFTP1.Passive := CheckBox1.Checked;
end;

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

end.