求救阿：为什么的的FTP客户端老是出现异常，麻烦各位高手给我看一下(200分)

wc1234 · 2006-06-05

不知道是哪里出现了问题，只要是在下载的过程中，文件还没有下载完成，如果我点击断开按钮，在关闭程序后就会提示我的程序异常。麻烦各位高手帮我看看，谢谢了
代码如下
unit mainf;

interface

uses
Windows, Messages, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComCtrls,
Menus, SysUtils, Classes, IdIntercept, IdBaseComponent, IdComponent, IdTCPConnection,
IdTCPClient, IdFTP, IdAntiFreezeBase, IdAntiFreeze, IdLogBase, IdLogDebug, IdGlobal,
IdLogEvent, IdFTPCommon, IdFTPList, IdTCPServer, IdFTPServer,
IdUserAccounts, IdSocks, IniFiles,XShadow, IdRFCReply, IdResourceStrings,IdSocketHandle,
IdIPWatch, Buttons;

type
TMainForm = class(TForm)
DirectoryListBox: TListBox;
IdFTP1: TIdFTP;
DebugListBox: TListBox;
Panel1: TPanel;
FtpServerEdit: TEdit;
ConnectButton: TButton;
Splitter1: TSplitter;
Label1: TLabel;
UploadOpenDialog1: TOpenDialog;
Panel3: TPanel;
SaveDialog1: TSaveDialog;
StatusBar1: TStatusBar;
TraceCheckBox: TCheckBox;
CommandPanel: TPanel;
UploadButton: TButton;
AbortButton: TButton;
BackButton: TButton;
DeleteButton: TButton;
DownloadButton: TButton;
UserIDEdit: TEdit;
PasswordEdit: TEdit;
Label2: TLabel;
Label3: TLabel;
IdAntiFreeze1: TIdAntiFreeze;
ProgressBar1: TProgressBar;
UsePassive: TCheckBox;
CurrentDirEdit: TEdit;
ChDirButton: TButton;
CreateDirButton: TButton;
PopupMenu1: TPopupMenu;
Download1: TMenuItem;
Upload1: TMenuItem;
Delete1: TMenuItem;
N1: TMenuItem;
Back1: TMenuItem;
IdLogEvent1: TIdLogEvent;
HeaderControl1: THeaderControl;
IdFTPServer: TIdFTPServer;
IdUserMgr: TIdUserManager;
Button1: TButton;
Port_input: TEdit;
Port: TLabel;
memlog: TMemo;
Label4: TLabel;
Label5: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Button2: TButton;
IdIPWatch1: TIdIPWatch;
Label6: TLabel;
Edit3: TEdit;
reflsh: TBitBtn;
procedure ConnectButtonClick(Sender: TObject);
procedure UploadButtonClick(Sender: TObject);
procedure DirectoryListBoxDblClick(Sender: TObject);
procedure DeleteButtonClick(Sender: TObject);
procedure IdFTP1Disconnected(Sender: TObject);
procedure AbortButtonClick(Sender: TObject);
procedure BackButtonClick(Sender: TObject);
procedure IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
const asStatusText: String);
procedure TraceCheckBoxClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure DirectoryListBoxClick(Sender: TObject);
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 UsePassiveClick(Sender: TObject);
procedure ChDirButtonClick(Sender: TObject);
procedure CreateDirButtonClick(Sender: TObject);
procedure IdLogEvent1Received(ASender: TComponent; const AText,
AData: String);
procedure IdLogEvent1Sent(ASender: TComponent; const AText,
AData: String);
procedure DebugListBoxDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure DirectoryListBoxDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
procedure HeaderControl1SectionResize(HeaderControl: THeaderControl;
Section: THeaderSection);
procedure IdFTPServerChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure IdFTPServerListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
procedure IdFTPServerStoreFile(ASender: TIdFTPServerThread;
const AFileName: String; AAppend: Boolean; var VStream: TStream);
procedure IdFTPServerRetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
procedure IdFTPServerMakeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure IdFTPServerDeleteFile(ASender: TIdFTPServerThread;
const APathName: String);
procedure IdFTPServerRemoveDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure IdFTPServerAfterUserLogin(ASender: TIdFTPServerThread);
procedure IdFTPServerRenameFile(ASender: TIdFTPServerThread;
const ARenameFromFile, ARenameToFile: String);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure reflshClick(Sender: TObject);
procedure IdFTPServerDisconnect(AThread: TIdPeerThread);
private
{ Private declarations }
AbortTransfer: Boolean;
TransferrignData: Boolean;
BytesToTransfer: LongWord;
STime: TDateTime;
//add----------------------------------
procedure SendRFCReply(ASender: TIdFTPServerThread; const ATextCode, AText:string);
procedure LogEvent(AMsg: string);
//-------------------------------------
procedure ChageDir(DirName: String);
procedure SetFunctionButtons(AValue: Boolean);
procedure SaveFTPHostInfo(Datatext, header: String);
procedure SaveFTPHostInfoPort(Datatext, header: String);
function GetHostInfo(header: String): String;
function GetHostInfoPort(header: String): String;
procedure PutToDebugLog(Operation, S1: String);
public
{ Public declarations }
//add------------------------------------
function LoadUserListFromFile: boolean;
procedure LoadWelcomeMsgFromFile;
function LoadServerConfig: boolean;
procedure SetFTPServerBinding(AIP: string; Aport: integer);
//--------------------------------------
end;

var
MainForm: TMainForm;
AverageSpeed: Double = 0;
ConfigFile : String = '/Config/Config.ini';
UserListFile :String ='/Config/Accounts.txt';
FTPHomeDir :String = 'C:/Temp/';
Signals : Integer = 0;
implementation

{$R *.dfm}

procedure TMainForm.SetFunctionButtons(AValue: Boolean);
Var
i: Integer;
begin
with CommandPanel do
for i := 0 to ControlCount - 1 do
if Controls.Name <> 'AbortButton' then Controls.Enabled := AValue;

with PopupMenu1 do
for i := 0 to Items.Count - 1 do Items.Enabled := AValue;

ChDirButton.Enabled := AValue;
CreateDirButton.Enabled := AValue;
end;

procedure TMainForm.ConnectButtonClick(Sender: TObject);
begin
ConnectButton.Enabled := false;
if IdFTP1.Connected then try
if TransferrignData then IdFTP1.Abort;

finally
CurrentDirEdit.Text := '/';
DirectoryListBox.Items.Clear;
SetFunctionButtons(false);
ConnectButton.Caption := '连接';
IdFTP1.Quit;
ConnectButton.Enabled := true;
ConnectButton.Default := true;
end
else with IdFTP1 do try
Username := UserIDEdit.Text;
Password := PasswordEdit.Text;
Host := FtpServerEdit.Text;
port :=StrToInt(Port_input.text);
Connect;
Self.ChageDir(CurrentDirEdit.Text);
SetFunctionButtons(true);
SaveFTPHostInfo(FtpServerEdit.Text, 'FTPHOST');
SaveFTPHostInfoPort(port_input.Text, 'FTPHOST');
finally
ConnectButton.Enabled := true;
if Connected then begin
ConnectButton.Caption := '断开';
ConnectButton.Default := false;
end;
end;
end;

procedure TMainForm.UploadButtonClick(Sender: TObject);
begin
if IdFTP1.Connected then begin
if UploadOpenDialog1.Execute then try
SetFunctionButtons(false);
IdFTP1.TransferType := ftBinary;

IdFTP1.Put(UploadOpenDialog1.FileName, ExtractFileName(UploadOpenDialog1.FileName));
ChageDir(idftp1.RetrieveCurrentDir);
finally
SetFunctionButtons(true);
end;
end;
end;

procedure TMainForm.ChageDir(DirName: String);
Var
LS: TStringList;
begin
LS := TStringList.Create;
try
SetFunctionButtons(false);
IdFTP1.ChangeDir(DirName);
IdFTP1.TransferType := ftASCII;

CurrentDirEdit.Text := IdFTP1.RetrieveCurrentDir;

DirectoryListBox.Items.Clear;
IdFTP1.List(LS);
DirectoryListBox.Items.Assign(LS);
if DirectoryListBox.Items.Count > 0 then
if AnsiPos('total', DirectoryListBox.Items[0]) > 0 then DirectoryListBox.Items.Delete(0);
finally
SetFunctionButtons(true);
LS.Free;
end;
end;

procedure TMainForm.DirectoryListBoxDblClick(Sender: TObject);
Var
Name{, Line}: String;
begin
if not IdFTP1.Connected then exit;
//Line := DirectoryListBox.Items[DirectoryListBox.ItemIndex];
Name := IdFTP1.DirectoryListing.Items[DirectoryListBox.ItemIndex].FileName;
if IdFTP1.DirectoryListing.Items[DirectoryListBox.ItemIndex].ItemType = ditDirectory then begin
// Change directory
SetFunctionButtons(false);
ChageDir(Name);
SetFunctionButtons(true);
end
else begin
try
SaveDialog1.FileName := Name;
if SaveDialog1.Execute then begin
SetFunctionButtons(false);

IdFTP1.TransferType := ftBinary;
BytesToTransfer := IdFTP1.Size(Name);

if FileExists(Name) then begin
case MessageDlg('File aready exists. Do you want to resume the download operation?',
mtConfirmation, mbYesNoCancel, 0) of
mrYes: begin
BytesToTransfer := BytesToTransfer - FileSizeByName(Name);
if(BytesToTransfer <> 0) then
begin
IdFTP1.Get(Name, SaveDialog1.FileName, false, true);
end
else
begin
IdFTP1.Get(Name, SaveDialog1.FileName, true);
end;
end;
mrNo: begin
IdFTP1.Get(Name, SaveDialog1.FileName, true);
end;
mrCancel: begin
exit;
end;
end;
end
else begin
IdFTP1.Get(Name, SaveDialog1.FileName, false);
end;
end;
finally
SetFunctionButtons(true);
end;
end;
end;

procedure TMainForm.DeleteButtonClick(Sender: TObject);
Var
Name: String;
begin
if not IdFTP1.Connected then exit;
Name := IdFTP1.DirectoryListing.Items[DirectoryListBox.ItemIndex].FileName;
if IdFTP1.DirectoryListing.Items[DirectoryListBox.ItemIndex].ItemType = ditDirectory then try
SetFunctionButtons(false);
idftp1.RemoveDir(Name);
ChageDir(idftp1.RetrieveCurrentDir);
finally
end
else
try
SetFunctionButtons(false);
idftp1.Delete(Name);
ChageDir(idftp1.RetrieveCurrentDir);
finally
end;
end;

procedure TMainForm.IdFTP1Disconnected(Sender: TObject);
begin
StatusBar1.Panels[1].Text := 'Disconnected.';
end;

procedure TMainForm.AbortButtonClick(Sender: TObject);
begin
AbortTransfer := true;

end;

procedure TMainForm.BackButtonClick(Sender: TObject);
begin
if not IdFTP1.Connected then exit;
try
ChageDir('..');
finally end;
end;

procedure TMainForm.IdFTP1Status(axSender: TObject; const axStatus: TIdStatus;
const asStatusText: String);
begin
DebugListBox.ItemIndex := DebugListBox.Items.Add(asStatusText);
StatusBar1.Panels[1].Text := asStatusText;
end;

procedure TMainForm.TraceCheckBoxClick(Sender: TObject);
begin
if TraceCheckBox.Checked then
IdFtp1.Intercept := IdLogEvent1
else
IdFtp1.Intercept := nil;

DebugListBox.Visible := TraceCheckBox.Checked;
if DebugListBox.Visible then Splitter1.Top := DebugListBox.Top + 5;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
SetFunctionButtons(false);
IdFtp1.Intercept := IdLogEvent1;

FtpServerEdit.Text := GetHostInfo('FTPHOST');
port_input.Text :=GetHostInfoPort('FTPHOST');
ProgressBar1.Parent := StatusBar1;
ProgressBar1.Top := 2;
ProgressBar1.Left := 1;
ProgressBar1.Align := alClient;
Edit1.Text:= IdIPWatch1.LocalIP;
end;

procedure TMainForm.DirectoryListBoxClick(Sender: TObject);
begin
if not IdFTP1.Connected then exit;
if DirectoryListBox.ItemIndex > -1 then begin
if IdFTP1.DirectoryListing.Items[DirectoryListBox.ItemIndex].ItemType = ditDirectory then DownloadButton.Caption := '更改目录'
else DownloadButton.Caption := '下载';
end;
end;

procedure TMainForm.IdFTP1Work(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCount: Integer);
Var
S: String;
TotalTime: TDateTime;
// RemainingTime: 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 := {(AverageSpeed + }(AWorkCount / 1024) / DLTime{) / 2};

if AverageSpeed > 0 then begin
Sec := Trunc(((BytesToTransfer - AWorkCount) / 1024) / AverageSpeed);

S := Format('%2d:%2d:%2d', [Sec div 3600, (Sec div 60) mod 60, Sec mod 60]);

S := 'Time remaining ' + S;
end
else S := '';

S := FormatFloat('0.00 KB/s', AverageSpeed) + '; ' + S;
case AWorkMode of
wmRead: StatusBar1.Panels[1].Text := 'Download speed ' + S;
wmWrite: StatusBar1.Panels[1].Text := 'Uploade speed ' + S;
end;

if AbortTransfer then
begin
IdFTP1.Abort;
IdFTP1.Quit;
IdFTP1.Connect();
SetFunctionButtons(true);
end;

ProgressBar1.Position := AWorkCount;
AbortTransfer := false;

end;

procedure TMainForm.IdFTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
const AWorkCountMax: Integer);
begin
TransferrignData := true;
AbortButton.Visible := true;
AbortTransfer := false;
STime := Now;
//if AWorkCountMax > 0 then ProgressBar1.Max := AWorkCountMax
//else
ProgressBar1.Max := AWorkCountMax;

AverageSpeed := 0;
end;

procedure TMainForm.IdFTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
AbortButton.Visible := false;
StatusBar1.Panels[1].Text := 'Transfer complete.';
BytesToTransfer := 0;
TransferrignData := false;
ProgressBar1.Position := 0;
AverageSpeed := 0;
end;

procedure TMainForm.UsePassiveClick(Sender: TObject);
begin
IdFTP1.Passive := UsePassive.Checked;
end;

procedure TMainForm.ChDirButtonClick(Sender: TObject);
begin
SetFunctionButtons(false);
ChageDir(CurrentDirEdit.Text);
SetFunctionButtons(true);
end;

procedure TMainForm.CreateDirButtonClick(Sender: TObject);
Var
S: String;
begin
S := InputBox('Make new directory', 'Name', '');
if S <> '' then
try
SetFunctionButtons(false);
IdFTP1.MakeDir(S);
ChageDir(CurrentDirEdit.Text);
finally
SetFunctionButtons(true);
end;
end;

procedure TMainForm.SaveFTPHostInfo(Datatext, header: String);
var
ServerIni: TIniFile;
begin
ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
ServerIni.WriteString('Server', header, Datatext);
ServerIni.UpdateFile;
ServerIni.Free;
end;

procedure TMainForm.SaveFTPHostInfoPort(Datatext, header: String);
var
ServerIni: TIniFile;
begin
ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
ServerIni.WriteString('Port', 'FTPPORT', Datatext);
ServerIni.UpdateFile;
ServerIni.Free;
end;

function TMainForm.GetHostInfo(header: String): String;
var
ServerName: String;
ServerIni: TIniFile;
begin
ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
ServerName := ServerIni.ReadString('Server', header, header);
ServerIni.Free;
result := ServerName;
end;

function TMainForm.GetHostInfoPort(header: String): String;
var
ServerIni: TIniFile;
ServerPort: String ;
begin
ServerIni := TIniFile.Create(ExtractFilePath(ParamStr(0)) + 'FtpHost.ini');
ServerPort := ServerIni.ReadString('Port', 'FTPPORT', '20');
ServerIni.Free;
result := ServerPort;
end;

procedure TMainForm.PutToDebugLog(Operation, S1: String);
Var
S: String;
begin
while Length(S1) > 0 do begin
if Pos(#13, S1) > 0 then begin
S := Copy(S1, 1, Pos(#13, S1) - 1);
Delete(S1, 1, Pos(#13, S1));
if S1[1] = #10 then Delete(S1, 1, 1);
end
else
S := S1;

DebugListBox.ItemIndex := DebugListBox.Items.Add(Operation + S);
end;
end;

procedure TMainForm.IdLogEvent1Received(ASender: TComponent; const AText,
AData: String);
begin
PutToDebugLog('<<- ', AData);
end;

procedure TMainForm.IdLogEvent1Sent(ASender: TComponent; const AText,
AData: String);
begin
PutToDebugLog('->> ', AData);
end;

procedure TMainForm.DebugListBoxDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
if Pos('>>', DebugListBox.Items[index]) > 1 then
DebugListBox.Canvas.Font.Color := clRed
else
DebugListBox.Canvas.Font.Color := clBlue;

if odSelected in State then begin
DebugListBox.Canvas.Brush.Color := $00895F0A;
DebugListBox.Canvas.Font.Color := clWhite;
end
else
DebugListBox.Canvas.Brush.Color := clWindow;

DebugListBox.Canvas.FillRect(Rect);

DebugListBox.Canvas.TextOut(Rect.Left, Rect.Top, DebugListBox.Items[index]);
end;

procedure TMainForm.DirectoryListBoxDrawItem(Control: TWinControl;
Index: Integer; Rect: TRect; State: TOwnerDrawState);
Var
R: TRect;
begin
if odSelected in State then begin
DirectoryListBox.Canvas.Brush.Color := $00895F0A;
DirectoryListBox.Canvas.Font.Color := clWhite;
end
else
DirectoryListBox.Canvas.Brush.Color := clWindow;

if Assigned(IdFTP1.DirectoryListing) and (IdFTP1.DirectoryListing.Count > Index) then begin
DirectoryListBox.Canvas.FillRect(Rect);
with IdFTP1.DirectoryListing.Items[Index] do begin
DirectoryListBox.Canvas.TextOut(Rect.Left, Rect.Top, IdFTP1.DirectoryListing.Items[Index].FileName);
R := Rect;

R.Left := Rect.Left + HeaderControl1.Sections.Items[0].Width;
R.Right := R.Left + HeaderControl1.Sections.Items[1].Width;
DirectoryListBox.Canvas.FillRect(R);
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, IntToStr(Size));

R.Left := R.Right;
R.Right := R.Left + HeaderControl1.Sections.Items[2].Width;
DirectoryListBox.Canvas.FillRect(R);

if ItemType = ditDirectory then begin
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, 'Directory');
end
else
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, 'File');

R.Left := R.Right;
R.Right := R.Left + HeaderControl1.Sections.Items[3].Width;
DirectoryListBox.Canvas.FillRect(R);
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, FormatDateTime('mm/dd/yyyy hh:mm', ModifiedDate));

R.Left := R.Right;
R.Right := R.Left + HeaderControl1.Sections.Items[4].Width;
DirectoryListBox.Canvas.FillRect(R);
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, GroupName);

R.Left := R.Right;
R.Right := R.Left + HeaderControl1.Sections.Items[5].Width;
DirectoryListBox.Canvas.FillRect(R);
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, OwnerName);

R.Left := R.Right;
R.Right := R.Left + HeaderControl1.Sections.Items[6].Width;
DirectoryListBox.Canvas.FillRect(R);
DirectoryListBox.Canvas.TextOut(R.Left, Rect.Top, OwnerPermissions + GroupPermissions + UserPermissions);
end;
end;
end;

procedure TMainForm.HeaderControl1SectionResize(
HeaderControl: THeaderControl; Section: THeaderSection);
begin
DirectoryListBox.Repaint;
end;

procedure TMainForm.SendRFCReply(ASender: TIdFTPServerThread; const ATextCode, AText: string);
var
RFCReply: TIdRFCReply;
begin
try
RFCReply := TIdRFCReply.Create(nil);
RFCReply.NumericCode := StrToInt(ATextCode);
RFCReply.TextCode := ATextCode;
RFCReply.Text.Text := AText;
ASender.Connection.WriteRFCReply(RFCReply);
finally
FreeAndNil(RFCReply);
end;
end;
// ToDo : Save in Config.ini
const
WelComeMessageFile = '/Config/Welcome.txt';
//读取欢迎信息文件
procedure TMainForm.LoadWelcomeMsgFromFile;
var
slWelcomMsg: TStringList;
begin
try
slWelcomMsg := TStringList.Create;
slWelcomMsg.LoadFromFile(GetCurrentDir + WelComeMessageFile);
idFTPServer.Greeting.Text.Text := slWelcomMsg.Text;
finally
FreeAndNil(slWelcomMsg);
end;
end;

function TMainForm.LoadUserListFromFile: boolean;
var
i: integer;
slUserList: TStringList;
UserAccount: TidUserAccount;
begin
Result := false;

try
slUserList := TStringList.Create;
//打开文件
slUserList.LoadFromFile(GetCurrentDir + UserListFile);

for i := 0 to slUserList.Count - 1 do
begin
UserAccount := idUserMgr.Accounts.Add;
UserAccount.UserName := GetToken(slUserList.Strings, 1);
UserAccount.Password := GetToken(slUserList.Strings, 2);
UserAccount.RealName := GetToken(slUserList.Strings, 3);
end;
finally
FreeAndNil(slUserList);
end;

if idUserMgr.Accounts.Count > 0 then
Result := true;

end;

function TMainForm.LoadServerConfig: boolean;
var
Port, DataPort: integer;
ServerINI: TIniFile;
ConfigFileName, IP: string;
begin
Result := False;
ConfigFileName := GetCurrentDir + ConfigFile;
try
if FileExists(ConfigFileName) then
begin
ServerINI := TIniFile.Create(ConfigFileName);

IP := Edit1.Text;
Port := StrToInt(Edit2.Text);

if IP = '' then
raise Exception.Create('Can not Find IP Parameter!');

if Port = 0 then
Port := idFTPServer.DefaultPort;

DataPort := StrToInt(Edit2.Text);

if DataPort <> 0 then
idFTPServer.DefaultPort := DataPort;

SetFTPServerBinding(IP, Port);

Result := true;
end
else
raise Exception.CreateFmt('Can not Find Config File : %s',
[ConfigFileName]);
finally
FreeAndNil(ServerINI);
end;
end;

procedure TMainForm.SetFTPServerBinding(AIP: string; APort: Integer);
var
hSocketInfo: TIdSocketHandle ;
begin
hSocketInfo := idFTPServer.Bindings.Add;
hSocketInfo.IP := AIP;
hSocketInfo.Port := APort;
end;

procedure TMainForm.IdFTPServerChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);

var
Path: string;
begin
Path := VDirectory;

if copy(Path, 1, 3) = '../' then
begin
Path := PathWithoutSlash(FTPHomeDir) + ASender.CurrentDir;
ReplaceString(Path, '/', '/', false);
Path := ParentDirectory(Path);

VDirectory := '/' + RelativePath(FTPHomeDir, Path);
ReplaceString(VDirectory, '/', '/', false);
end
else
begin
Path := PathWithoutSlash(FTPHomeDir) + Path;
ReplaceString(Path, '/', '/', false);
end;

if not DirectoryExists(Path) then
begin
SendRFCReply(ASender, '550', Format(RSLPDDirectoryDoesNotExist,
[VDirectory]));

VDirectory := ASender.CurrentDir;
end;

end;

procedure TMainForm.IdFTPServerListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
var
flItem: TIdFTPListItem;
SearchRec: TSearchRec;
sDir: string;

begin
ADirectoryListing.BeginUpdate;

sDir := PathWithoutSlash(FTPHomeDir) + APath;
ReplaceString(sDir, '/', '/', false);

if FindFirst(sDir + '*.*', faAnyFile, SearchRec) = 0 then
begin
repeat
flItem := ADirectoryListing.Add;
flItem.FileName := SearchRec.Name;

flItem.UserPermissions := 'rxx';
flItem.GroupPermissions := 'rxx';
flItem.OwnerPermissions := 'rxx';
flItem.OwnerName := 'share';
flItem.GroupName := 'sharegroup';

flItem.Size := SearchRec.Size;
flItem.ModifiedDate := FileDateToDateTime(SearchRec.Time);

if (SearchRec.Attr and faDirectory) = 0 then
begin
flItem.ItemType := ditFile;
end
else
begin
flItem.ItemType := ditDirectory;
end;
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;

ADirectoryListing.EndUpdate;

end;

procedure TMainForm.IdFTPServerStoreFile(ASender: TIdFTPServerThread;
const AFileName: String; AAppend: Boolean; var VStream: TStream);
var
tarFileName: string;

begin
tarFileName := PathWithoutSlash(FTPHomeDir) + AFileName;
ReplaceString(tarFileName, '/', '/', false);

VStream := TFileStream.Create(tarFileName, fmCreate or fmOpenReadWrite);
VStream.Position := 0;

ASender.Connection.ReadStream(VStream, VStream.Size, false);

LogEvent(format('User : %s Retrieve File "%s"', [ASender.Username,tarFileName]));

end;

procedure TMainForm.LogEvent(AMsg: string);
begin
memLog.Lines.Add(AMsg);
end;

procedure TMainForm.IdFTPServerRetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
var
tarFileName: string;

begin
tarFileName := PathWithoutSlash(FTPHomeDir) + AFileName;
ReplaceString(tarFileName, '/', '/', false);

if FileExists(tarFileName) then
begin
VStream := TFileStream.Create(tarFileName, fmShareDenyNone or fmOpenRead);
LogEvent(format('User : %s Retrieve File "%s"', [ASender.Username,
tarFileName]));
end
else
SendRFCReply(ASender, '550', format('%s: No such file or directory.',
[AFileName]));

end;

procedure TMainForm.IdFTPServerMakeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
var
Path: string;
begin
if( Signals <> 0)
then
begin
Path := PathWithoutSlash(FTPHomeDir) + VDirectory;
ReplaceString(Path, '/', '/', false);

if not DirectoryExists(Path) then
begin
if CreateDir(Path) then
LogEvent(format('User : %s make directory "%s"', [ASender.Username, Path]))
else
SendRFCReply(ASender, '550', format('%s: Can not make Directory.',
[VDirectory]));
end
else
SendRFCReply(ASender, '550', format('%s: Directory exists.', [VDirectory]))
end
else
SendRFCReply(ASender, '550', format('%s: Can not make Directory.',
[VDirectory]));

end;

procedure TMainForm.IdFTPServerDeleteFile(ASender: TIdFTPServerThread;
const APathName: String);
var
tarFileName: string;
begin
if(signals <> 0)
then
begin
tarFileName := PathWithoutSlash(FTPHomeDir) + ASender.CurrentDir + '/' +
APathName;
ReplaceString(tarFileName, '/', '/', false);

if FileExists(tarFileName) then
begin
if DeleteFile(tarFileName) then
LogEvent(format('User : %s delete file "%s"', [ASender.Username,
tarFileName]))
else
SendRFCReply(ASender, '550', Format('%s : Can not delete file.',
[APathName]));
end
else
SendRFCReply(ASender, '550', Format(RSFileNotFound,
[APathName]));
end

end;

procedure TMainForm.IdFTPServerRemoveDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
var
Path: string;
begin
if(signals <> 0)
then
begin
Path := PathWithoutSlash(FTPHomeDir) + VDirectory;
ReplaceString(Path, '/', '/', false);

if DirectoryExists(Path) then
begin
RmDir(Path);
if IOResult = 0 then
LogEvent(format('User : %s make directory "%s"', [ASender.Username, Path]))
else
SendRFCReply(ASender, '550', format('%s: Can not Remove Directory',
[VDirectory]));
end
else
SendRFCReply(ASender, '550', format('%s: No such file or directory.',
[VDirectory]));
end

end;

procedure TMainForm.IdFTPServerAfterUserLogin(ASender: TIdFTPServerThread);
begin
ASender.HomeDir := FTPHomeDir;
ASender.CurrentDir := '/';

LogEvent(format('User : %s Login in Home Directory "%s"', [ASender.Username,
ASender.CurrentDir]));
if(ASender.Username<> 'anonymous') then
Signals :=1;

end;

procedure TMainForm.IdFTPServerRenameFile(ASender: TIdFTPServerThread;
const ARenameFromFile, ARenameToFile: String);
var
OldName, NewName, Path: string;
begin
if(signals<>0)
then
begin
Path := PathWithoutSlash(FTPHomeDir) + ASender.CurrentDir + '/';
ReplaceString(Path, '/', '/', false);

OldName := Path + ARenameFromFile;
NewName := Path + ARenameToFile;

if FileExists(Path + '/' + ARenameFromFile) then
if RenameFile(OldName, NewName) then
LogEvent(format('User : %s rename file : "%s" -> "%s"', [ASender.Username,
OldName, NewName]))
else
SendRFCReply(ASender, '550',
format('Can not rename file : %s',
[OldName]))
else
SendRFCReply(ASender, '550', format(RSFileNotFound, [OldName]));
end

end;

procedure TMainForm.Button1Click(Sender: TObject);
begin
LoadUserListFromFile;
idFTPServer.UserAccounts := idUserMgr;
LoadWelcomeMsgFromFile;
idFTpServer.EmulateSystem := ftpsUnix;
idFTpServer.SystemType := 'Unix Type:L8';
idFTPServer.Bindings.Clear;
LoadServerConfig;
idFTPServer.Active := true;
Button1.Enabled:=false;
memlog.Clear;
idFTPServer.AllowAnonymousLogin := true;
memlog.Text:='FTP 服务打开';
Button2.Enabled:=true;
end;

procedure TMainForm.Button2Click(Sender: TObject);
begin
Button1.Enabled:=true;
IdFTPServer.Active:=false;
Button2.Enabled:=false;
LogEvent('FTP服务关闭');
end;

procedure TMainForm.reflshClick(Sender: TObject);
begin
SetFunctionButtons(false);
ChageDir('/');
SetFunctionButtons(true);
end;

procedure TMainForm.IdFTPServerDisconnect(AThread: TIdPeerThread);
begin
button2.Enabled:=false;
end;

end.

jsjxuwenjun · 2006-06-05

if AbortTransfer then//在传文件
begin
IdFTP1.Abort;
IdFTP1.Quit;
//IdFTP1.Connect();//错误(已经退出,你还要去连接......)
SetFunctionButtons(true);
end;

试试这样:
try
if AbortTransfer then //正在传送文件吗？
IdFTP1.Abort; // 断开连接
IdFTP1.Quit; //退出连接
except
ShowMessage('正在传送文件，请稍候！');
Exit;
end;

wc1234 · 2006-06-05

不是的出现异常的过程是这样的你选择一个文件下载，这个文件还没有下载完全，然后你点击断开按钮，然后关闭程序，异常就产生了，如果文件下载完全了你关闭程序又不会有
我估计就是abort的问题，文件正在下载，然后突然断开了的问题
异常说的是：应用程序发生异常，未知的软件异常(0x0eedfde)，位置为0x7c81eb33
点击确定后，出现Application error的对话框，内容是Exception EIdTerminateThreadTimeout in module FTP.exe at 000A237A Terminate Thread Timeout

jsjxuwenjun · 2006-06-06

你在退出程序里加:
try.....except...end;不就好了吗?

wc1234 · 2006-06-06

尊敬的jsjxuwenjun ]
你能把你的邮箱给我或者MSN也行，因为我在做毕业设计，现在怎么调试都不行我发给您看看可以吗？谢谢了！这两百分我给你好了，谢谢！可以吗？

phzongna · 2006-06-08

if AbortTransfer then//在传文件
begin
IdFTP1.KillDataChannel;
IdFTP1.Quit;
SetFunctionButtons(true);
end;
如果还出错就用:
if AbortTransfer then//在传文件
begin
IdFTP1.KillDataChannel;
IdFTP1.Disconnect;
SetFunctionButtons(true);
end; 试试

wc1234 · 2006-06-11

可以了谢谢phzongna大哥搞定了谢谢您我的MSN是wuly12345@hotmail.com 有时间大家多联系我还有很多东西要向你请教呵呵

wc1234 · 2006-06-11

多人接受答案了。

求救阿：为什么的的FTP客户端老是出现异常，麻烦各位高手给我看一下(200分)

wc1234

Unregistered / Unconfirmed

jsjxuwenjun

Unregistered / Unconfirmed

wc1234

Unregistered / Unconfirmed

jsjxuwenjun

Unregistered / Unconfirmed

wc1234

Unregistered / Unconfirmed

phzongna

Unregistered / Unconfirmed

wc1234

Unregistered / Unconfirmed

wc1234

Unregistered / Unconfirmed

Similar threads