Delphi - Indy TIdFTPServer封装类

在Delphi 7开发下有强大的Indy控件，版本为9，要实现一个FTP服务器，参考自带的例子，发现还要写很多函数，而且不支持中文显示文件列表等等。

于是，自己改进封装了下，形成一个TFTPServer类。

源码如下：

  1 {*******************************************************}  
  2 {                                                       }  
  3 {       系统名称 FTP服务器类                            }  
  4 {       版权所有 (C) http://blog.csdn.net/akof1314      }  
  5 {       单元名称 FTPServer.pas                          }  
  6 {       单元功能 在Delphi 7下TIdFTPServer实现FTP服务器  }  
  7 {                                                       }  
  8 {*******************************************************}  
  9 unit FTPServer;  
 10   
 11 interface  
 12   
 13 uses  
 14   Classes,  Windows,  Sysutils,  IdFTPList,  IdFTPServer,  Idtcpserver,  IdSocketHandle,  Idglobal,  IdHashCRC, IdStack;  
 15 {------------------------------------------------------------------------------- 
 16   功能:  自定义消息，方便与窗体进行消息传递 
 17 -------------------------------------------------------------------------------}  
 18   type  
 19     TFtpNotifyEvent = procedure (ADatetime: TDateTime;AUserIP, AEventMessage: string) of object;  
 20 {------------------------------------------------------------------------------- 
 21   功能:  FTP服务器类 
 22 -------------------------------------------------------------------------------}  
 23   type  
 24   TFTPServer = class  
 25   private  
 26     FUserName,FUserPassword,FBorrowDirectory: string;  
 27     FBorrowPort: Integer;  
 28     IdFTPServer: TIdFTPServer;  
 29     FOnFtpNotifyEvent: TFtpNotifyEvent;  
 30     procedure IdFTPServer1UserLogin( ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean ) ;  
 31     procedure IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;  
 32     procedure IdFTPServer1RenameFile( ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string ) ;  
 33     procedure IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream ) ;  
 34     procedure IdFTPServer1StoreFile( ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;  
 35     procedure IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;  
 36     procedure IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;  
 37     procedure IdFTPServer1GetFileSize( ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 ) ;  
 38     procedure IdFTPServer1DeleteFile( ASender: TIdFTPServerThread; const APathname: string ) ;  
 39     procedure IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread; var VDirectory: string ) ;  
 40     procedure IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;  
 41     procedure IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;  
 42   protected  
 43     function TransLatePath( const APathname, homeDir: string ) : string;  
 44   public  
 45     constructor Create; reintroduce;  
 46     destructor Destroy; override;  
 47     procedure Run;  
 48     procedure Stop;  
 49     function GetBindingIP():string;  
 50     property UserName: string read FUserName write FUserName;  
 51     property UserPassword: string read FUserPassword write FUserPassword;  
 52     property BorrowDirectory: string read FBorrowDirectory write FBorrowDirectory;  
 53     property BorrowPort: Integer read FBorrowPort write FBorrowPort;  
 54     property OnFtpNotifyEvent: TFtpNotifyEvent read FOnFtpNotifyEvent write FOnFtpNotifyEvent;  
 55   end;  
 56   
 57 implementation  
 58   
 59 {------------------------------------------------------------------------------- 
 60   过程名:    TFTPServer.Create 
 61   功能:      创建函数 
 62   参数:      无 
 63   返回值:    无 
 64 -------------------------------------------------------------------------------}  
 65 constructor TFTPServer.Create;  
 66 begin  
 67   IdFTPServer := tIdFTPServer.create( nil ) ;  
 68   IdFTPServer.DefaultPort := 21;               //默认端口号  
 69   IdFTPServer.AllowAnonymousLogin := False;   //是否允许匿名登录  
 70   IdFTPServer.EmulateSystem := ftpsUNIX;  
 71   IdFTPServer.HelpReply.text := '帮助还未实现！';  
 72   IdFTPServer.OnChangeDirectory := IdFTPServer1ChangeDirectory;  
 73   IdFTPServer.OnGetFileSize := IdFTPServer1GetFileSize;  
 74   IdFTPServer.OnListDirectory := IdFTPServer1ListDirectory;  
 75   IdFTPServer.OnUserLogin := IdFTPServer1UserLogin;  
 76   IdFTPServer.OnRenameFile := IdFTPServer1RenameFile;  
 77   IdFTPServer.OnDeleteFile := IdFTPServer1DeleteFile;  
 78   IdFTPServer.OnRetrieveFile := IdFTPServer1RetrieveFile;  
 79   IdFTPServer.OnStoreFile := IdFTPServer1StoreFile;  
 80   IdFTPServer.OnMakeDirectory := IdFTPServer1MakeDirectory;  
 81   IdFTPServer.OnRemoveDirectory := IdFTPServer1RemoveDirectory;  
 82   IdFTPServer.Greeting.Text.Text := '欢迎进入FTP服务器';  
 83   IdFTPServer.Greeting.NumericCode := 220;  
 84   IdFTPServer.OnDisconnect := IdFTPServer1DisConnect;  
 85   with IdFTPServer.CommandHandlers.add do  
 86   begin  
 87     Command := 'XCRC';   //可以迅速验证所下载的文档是否和源文档一样  
 88     OnCommand := IdFTPServer1CommandXCRC;  
 89   end;  
 90 end;  
 91 {------------------------------------------------------------------------------- 
 92   过程名:    CalculateCRC 
 93   功能:      计算CRC         
 94   参数:      const path: string 
 95   返回值:    string 
 96 -------------------------------------------------------------------------------}  
 97 function CalculateCRC( const path: string ) : string;  
 98 var  
 99   f: tfilestream;  
100   value: dword;  
101   IdHashCRC32: TIdHashCRC32;  
102 begin  
103   IdHashCRC32 := nil;  
104   f := nil;  
105   try  
106     IdHashCRC32 := TIdHashCRC32.create;  
107     f := TFileStream.create( path, fmOpenRead or fmShareDenyWrite ) ;  
108     value := IdHashCRC32.HashValue( f ) ;  
109     result := inttohex( value, 8 ) ;  
110   finally  
111     f.free;  
112     IdHashCRC32.free;  
113   end;  
114 end;  
115   
116 {------------------------------------------------------------------------------- 
117   过程名:    TFTPServer.IdFTPServer1CommandXCRC 
118   功能:      XCRC命令         
119   参数:      ASender: TIdCommand 
120   返回值:    无 
121 -------------------------------------------------------------------------------}  
122 procedure TFTPServer.IdFTPServer1CommandXCRC( ASender: TIdCommand ) ;  
123 // note, this is made up, and not defined in any rfc.  
124 var  
125   s: string;  
126 begin  
127   with TIdFTPServerThread( ASender.Thread ) do  
128   begin  
129     if Authenticated then  
130     begin  
131       try  
132         s := ProcessPath( CurrentDir, ASender.UnparsedParams ) ;  
133         s := TransLatePath( s, TIdFTPServerThread( ASender.Thread ) .HomeDir ) ;  
134         ASender.Reply.SetReply( 213, CalculateCRC( s ) ) ;  
135       except  
136         ASender.Reply.SetReply( 500, 'file error' ) ;  
137       end;  
138     end;  
139   end;  
140 end;  
141   
142 {------------------------------------------------------------------------------- 
143   过程名:    TFTPServer.Destroy 
144   功能:      析构函数         
145   参数:      无 
146   返回值:    无 
147 -------------------------------------------------------------------------------}  
148 destructor TFTPServer.Destroy;  
149 begin  
150   IdFTPServer.free;  
151   inherited destroy;  
152 end;  
153   
154 function StartsWith( const str, substr: string ) : boolean;  
155 begin  
156   result := copy( str, 1, length( substr ) ) = substr;  
157 end;  
158   
159 {------------------------------------------------------------------------------- 
160   过程名:    TFTPServer.Run 
161   功能:      开启服务         
162   参数:      无 
163   返回值:    无 
164 -------------------------------------------------------------------------------}  
165 procedure TFTPServer.Run;  
166 begin  
167   IdFTPServer.DefaultPort := BorrowPort;  
168   IdFTPServer.Active := True;  
169 end;  
170   
171 {------------------------------------------------------------------------------- 
172   过程名:    TFTPServer.Stop 
173   功能:      关闭服务         
174   参数:      无 
175   返回值:    无 
176 -------------------------------------------------------------------------------}  
177 procedure TFTPServer.Stop;  
178 begin   
179   IdFTPServer.Active := False;  
180 end;  
181   
182 {------------------------------------------------------------------------------- 
183   过程名:    TFTPServer.GetBindingIP 
184   功能:      获取绑定的IP地址         
185   参数:       
186   返回值:    string 
187 -------------------------------------------------------------------------------}  
188 function TFTPServer.GetBindingIP():string ;  
189 begin  
190   Result := GStack.LocalAddress;    
191 end;  
192 {------------------------------------------------------------------------------- 
193   过程名:    BackSlashToSlash 
194   功能:      反斜杠到斜杠 
195   参数:      const str: string 
196   返回值:    string 
197 -------------------------------------------------------------------------------}  
198 function BackSlashToSlash( const str: string ) : string;  
199 var  
200   a: dword;  
201 begin  
202   result := str;  
203   for a := 1 to length( result ) do  
204     if result[a] = '/' then  
205       result[a] := '/';  
206 end;  
207   
208 {------------------------------------------------------------------------------- 
209   过程名:    SlashToBackSlash 
210   功能:      斜杠到反斜杠         
211   参数:      const str: string 
212   返回值:    string 
213 -------------------------------------------------------------------------------}  
214 function SlashToBackSlash( const str: string ) : string;  
215 var  
216   a: dword;  
217 begin  
218   result := str;  
219   for a := 1 to length( result ) do  
220     if result[a] = '/' then  
221       result[a] := '/';  
222 end;  
223   
224 {------------------------------------------------------------------------------- 
225   过程名:    TFTPServer.TransLatePath 
226   功能:      路径名称翻译         
227   参数:      const APathname, homeDir: string 
228   返回值:    string 
229 -------------------------------------------------------------------------------}  
230 function TFTPServer.TransLatePath( const APathname, homeDir: string ) : string;  
231 var  
232   tmppath: string;  
233 begin  
234   result := SlashToBackSlash(Utf8ToAnsi(homeDir) ) ;  
235   tmppath := SlashToBackSlash( Utf8ToAnsi(APathname) ) ;  
236   if homedir = '/' then  
237   begin  
238     result := tmppath;  
239     exit;  
240   end;  
241   
242   if length( APathname ) = 0 then  
243     exit;  
244   if result[length( result ) ] = '/' then  
245     result := copy( result, 1, length( result ) - 1 ) ;  
246   if tmppath[1] <> '/' then  
247     result := result + '/';  
248   result := result + tmppath;  
249 end;  
250   
251 {------------------------------------------------------------------------------- 
252   过程名:    GetNewDirectory 
253   功能:      得到新目录         
254   参数:      old, action: string 
255   返回值:    string 
256 -------------------------------------------------------------------------------}  
257 function GetNewDirectory( old, action: string ) : string;  
258 var  
259   a: integer;  
260 begin  
261   if action = '../' then  
262   begin  
263     if old = '/' then  
264     begin  
265       result := old;  
266       exit;  
267     end;  
268     a := length( old ) - 1;  
269     while ( old[a] <> '/' ) and ( old[a] <> '/' ) do  
270       dec( a ) ;  
271     result := copy( old, 1, a ) ;  
272     exit;  
273   end;  
274   if ( action[1] = '/' ) or ( action[1] = '/' ) then  
275     result := action  
276   else  
277     result := old + action;  
278 end;  
279   
280 {------------------------------------------------------------------------------- 
281   过程名:    TFTPServer.IdFTPServer1UserLogin 
282   功能:      允许服务器执行一个客户端连接的用户帐户身份验证         
283   参数:      ASender: TIdFTPServerThread; const AUsername, APassword: string; var AAuthenticated: Boolean 
284   返回值:    无 
285 -------------------------------------------------------------------------------}  
286 procedure TFTPServer.IdFTPServer1UserLogin( ASender: TIdFTPServerThread;  
287   const AUsername, APassword: string; var AAuthenticated: Boolean ) ;  
288 begin  
289   AAuthenticated := ( AUsername = UserName ) and ( APassword = UserPassword ) ;  
290   if not AAuthenticated then  
291     exit;  
292   ASender.HomeDir := AnsiToUtf8(BorrowDirectory);  
293   asender.currentdir := '/';  
294   if Assigned(FOnFtpNotifyEvent) then  
295     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'用户登录服务器');  
296 end;  
297   
298 {------------------------------------------------------------------------------- 
299   过程名:    TFTPServer.IdFTPServer1ListDirectory 
300   功能:      允许服务器生成格式化的目录列表         
301   参数:      ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems 
302   返回值:    无 
303 -------------------------------------------------------------------------------}  
304 procedure TFTPServer.IdFTPServer1ListDirectory( ASender: TIdFTPServerThread; const APath: string; ADirectoryListing: TIdFTPListItems ) ;  
305   
306   procedure AddlistItem( aDirectoryListing: TIdFTPListItems; Filename: string; ItemType: TIdDirItemType; size: int64; date: tdatetime ) ;  
307   var  
308     listitem: TIdFTPListItem;  
309   begin  
310     listitem := aDirectoryListing.Add;  
311     listitem.ItemType := ItemType; //表示一个文件系统的属性集  
312     listitem.FileName := AnsiToUtf8(Filename);  //名称分配给目录中的列表项,这里防止了中文乱码  
313     listitem.OwnerName := 'anonymous';//代表了用户拥有的文件或目录项的名称  
314     listitem.GroupName := 'all';    //指定组名拥有的文件名称或目录条目  
315     listitem.OwnerPermissions := 'rwx'; //拥有者权限，R读W写X执行  
316     listitem.GroupPermissions := 'rwx'; //组拥有者权限  
317     listitem.UserPermissions := 'rwx';  //用户权限，基于用户和组权限  
318     listitem.Size := size;  
319     listitem.ModifiedDate := date;  
320   end;  
321   
322 var  
323   f: tsearchrec;  
324   a: integer;  
325 begin  
326   ADirectoryListing.DirectoryName := apath;   
327   a := FindFirst( TransLatePath( apath, ASender.HomeDir ) + '*.*', faAnyFile, f ) ;  
328   while ( a = 0 ) do  
329   begin  
330     if ( f.Attr and faDirectory > 0 ) then  
331       AddlistItem( ADirectoryListing, f.Name, ditDirectory, f.size, FileDateToDateTime( f.Time ) )  
332     else  
333       AddlistItem( ADirectoryListing, f.Name, ditFile, f.size, FileDateToDateTime( f.Time ) ) ;  
334     a := FindNext( f ) ;  
335   end;  
336   
337   FindClose( f ) ;  
338 end;  
339   
340 {------------------------------------------------------------------------------- 
341   过程名:    TFTPServer.IdFTPServer1RenameFile 
342   功能:      允许服务器重命名服务器文件系统中的文件         
343   参数:      ASender: TIdFTPServerThread; const ARenameFromFile, ARenameToFile: string 
344   返回值:    无 
345 -------------------------------------------------------------------------------}  
346 procedure TFTPServer.IdFTPServer1RenameFile( ASender: TIdFTPServerThread;  
347   const ARenameFromFile, ARenameToFile: string ) ;  
348 begin  
349   try  
350     if not MoveFile( pchar( TransLatePath( ARenameFromFile, ASender.HomeDir ) ) , pchar( TransLatePath( ARenameToFile, ASender.HomeDir ) ) ) then  
351       RaiseLastOSError;  
352   except  
353     on e:Exception do  
354     begin  
355       if Assigned(FOnFtpNotifyEvent) then  
356         OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名文件[' + Utf8ToAnsi(ARenameFromFile) + ']失败，原因是' + e.Message);  
357       Exit;  
358     end;  
359   end;  
360   if Assigned(FOnFtpNotifyEvent) then  
361     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'重命名文件[' + Utf8ToAnsi(ARenameFromFile) + ']为[' + Utf8ToAnsi(ARenameToFile) + ']');  
362 end;  
363   
364 {------------------------------------------------------------------------------- 
365   过程名:    TFTPServer.IdFTPServer1RetrieveFile 
366   功能:      允许从服务器下载文件系统中的文件 
367   参数:      ASender: TIdFTPServerThread; const AFilename: string; var VStream: TStream 
368   返回值:    无 
369 -------------------------------------------------------------------------------}  
370 procedure TFTPServer.IdFTPServer1RetrieveFile( ASender: TIdFTPServerThread;  
371   const AFilename: string; var VStream: TStream ) ;  
372 begin  
373   VStream := TFileStream.Create( translatepath( AFilename, ASender.HomeDir ) , fmopenread or fmShareDenyWrite ) ;  
374   if Assigned(FOnFtpNotifyEvent) then  
375     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'下载文件[' + Utf8ToAnsi(AFilename) + ']');  
376 end;  
377   
378 {------------------------------------------------------------------------------- 
379   过程名:    TFTPServer.IdFTPServer1StoreFile 
380   功能:      允许在服务器上传文件系统中的文件 
381   参数:      ASender: TIdFTPServerThread; const AFilename: string; AAppend: Boolean; var VStream: TStream 
382   返回值:    无 
383 -------------------------------------------------------------------------------}  
384 procedure TFTPServer.IdFTPServer1StoreFile( ASender: TIdFTPServerThread;  
385   const AFilename: string; AAppend: Boolean; var VStream: TStream ) ;  
386 begin  
387   if FileExists( translatepath( AFilename, ASender.HomeDir ) ) and AAppend then  
388   begin  
389     VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmOpenWrite or fmShareExclusive ) ;  
390     VStream.Seek( 0, soFromEnd ) ;  
391   end  
392   else  
393     VStream := TFileStream.create( translatepath( AFilename, ASender.HomeDir ) , fmCreate or fmShareExclusive ) ;  
394   if Assigned(FOnFtpNotifyEvent) then  
395     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'上传文件[' + Utf8ToAnsi(AFilename) + ']');  
396 end;  
397   
398 {------------------------------------------------------------------------------- 
399   过程名:    TFTPServer.IdFTPServer1RemoveDirectory 
400   功能:      允许服务器在服务器删除文件系统的目录         
401   参数:      ASender: TIdFTPServerThread; var VDirectory: string 
402   返回值:    无 
403 -------------------------------------------------------------------------------}  
404 procedure TFTPServer.IdFTPServer1RemoveDirectory( ASender: TIdFTPServerThread;  
405   var VDirectory: string ) ;  
406 begin  
407   try  
408     RmDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;  
409   except  
410     on e:Exception do  
411     begin  
412       if Assigned(FOnFtpNotifyEvent) then  
413         OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目录[' + Utf8ToAnsi(VDirectory) + ']失败，原因是' + e.Message);  
414       Exit;  
415     end;  
416   end;  
417   if Assigned(FOnFtpNotifyEvent) then  
418     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除目录[' + Utf8ToAnsi(VDirectory) + ']');  
419 end;  
420   
421 {------------------------------------------------------------------------------- 
422   过程名:    TFTPServer.IdFTPServer1MakeDirectory 
423   功能:      允许服务器从服务器中创建一个新的子目录 
424   参数:      ASender: TIdFTPServerThread; var VDirectory: string 
425   返回值:    无 
426 -------------------------------------------------------------------------------}  
427 procedure TFTPServer.IdFTPServer1MakeDirectory( ASender: TIdFTPServerThread;  
428   var VDirectory: string ) ;  
429 begin  
430   try  
431     MkDir( TransLatePath( VDirectory, ASender.HomeDir ) ) ;  
432   except  
433     on e:Exception do  
434     begin  
435       if Assigned(FOnFtpNotifyEvent) then  
436         OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'创建目录[' + Utf8ToAnsi(VDirectory) + ']失败，原因是' + e.Message);  
437       Exit;  
438     end;  
439   end;  
440   if Assigned(FOnFtpNotifyEvent) then  
441     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'创建目录[' + Utf8ToAnsi(VDirectory) + ']');  
442 end;  
443   
444 {------------------------------------------------------------------------------- 
445   过程名:    TFTPServer.IdFTPServer1GetFileSize 
446   功能:      允许服务器检索在服务器文件系统的文件的大小         
447   参数:      ASender: TIdFTPServerThread; const AFilename: string; var VFileSize: Int64 
448   返回值:    无 
449 -------------------------------------------------------------------------------}  
450 procedure TFTPServer.IdFTPServer1GetFileSize( ASender: TIdFTPServerThread;  
451   const AFilename: string; var VFileSize: Int64 ) ;  
452 begin  
453   VFileSize := FileSizeByName( TransLatePath( AFilename, ASender.HomeDir ) ) ;  
454   if Assigned(FOnFtpNotifyEvent) then  
455     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'获取文件大小');  
456 end;  
457   
458 {------------------------------------------------------------------------------- 
459   过程名:    TFTPServer.IdFTPServer1DeleteFile 
460   功能:      允许从服务器中删除的文件系统中的文件 
461   参数:      ASender: TIdFTPServerThread; const APathname: string 
462   返回值:    无 
463 -------------------------------------------------------------------------------}  
464 procedure TFTPServer.IdFTPServer1DeleteFile( ASender: TIdFTPServerThread;  
465   const APathname: string ) ;  
466 begin  
467   try  
468     DeleteFile( pchar( TransLatePath( ASender.CurrentDir + '/' + APathname, ASender.HomeDir ) ) ) ;  
469   except  
470     on e:Exception do  
471     begin  
472       if Assigned(FOnFtpNotifyEvent) then  
473         OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除文件[' + Utf8ToAnsi(APathname) + ']失败，原因是' + e.Message);  
474       Exit;  
475     end;  
476   end;  
477   if Assigned(FOnFtpNotifyEvent) then  
478     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'删除文件[' + Utf8ToAnsi(APathname) + ']');  
479 end;  
480   
481 {------------------------------------------------------------------------------- 
482   过程名:    TFTPServer.IdFTPServer1ChangeDirectory 
483   功能:      允许服务器选择一个文件系统路径         
484   参数:      ASender: TIdFTPServerThread; var VDirectory: string 
485   返回值:    无 
486 -------------------------------------------------------------------------------}  
487 procedure TFTPServer.IdFTPServer1ChangeDirectory( ASender: TIdFTPServerThread;  
488   var VDirectory: string ) ;  
489 begin  
490   VDirectory := GetNewDirectory( ASender.CurrentDir, VDirectory ) ;  
491   if Assigned(FOnFtpNotifyEvent) then  
492     OnFtpNotifyEvent(Now, ASender.Connection.Socket.Binding.PeerIP,'进入目录[' + Utf8ToAnsi(VDirectory) + ']');  
493 end;  
494   
495 {------------------------------------------------------------------------------- 
496   过程名:    TFTPServer.IdFTPServer1DisConnect 
497   功能:      失去网络连接         
498   参数:      AThread: TIdPeerThread 
499   返回值:    无 
500 -------------------------------------------------------------------------------}  
501 procedure TFTPServer.IdFTPServer1DisConnect( AThread: TIdPeerThread ) ;  
502 begin  
503   //  nothing much here  
504 end;  
505 end.

使用工程示例：

 1 unit Unit1; 
 2  
 3 interface 
 4  
 5 uses 
 6   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 
 7   Dialogs, StdCtrls, FTPServer; 
 8  
 9 type 
10   TForm1 = class(TForm) 
11     btn1: TButton; 
12     btn2: TButton; 
13     edt_BorrowDirectory: TEdit; 
14     lbl1: TLabel; 
15     mmo1: TMemo; 
16     lbl2: TLabel; 
17     edt_BorrowPort: TEdit; 
18     lbl3: TLabel; 
19     edt_UserName: TEdit; 
20     lbl4: TLabel; 
21     edt_UserPassword: TEdit; 
22     procedure btn1Click(Sender: TObject); 
23     procedure btn2Click(Sender: TObject); 
24     procedure TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string); 
25   private 
26     FFtpServer: TFTPServer; 
27   public 
28     { Public declarations } 
29   end; 
30  
31 var 
32   Form1: TForm1; 
33  
34 implementation 
35  
36  
37  
38 {$R *.dfm} 
39  
40 procedure TForm1.btn1Click(Sender: TObject); 
41 begin 
42   if not Assigned(FFtpServer) then 
43   begin 
44     FFtpServer := TFTPServer.Create; 
45     FFtpServer.UserName := Trim(edt_UserName.Text); 
46     FFtpServer.UserPassword := Trim(edt_UserPassword.Text); 
47     FFtpServer.BorrowDirectory := Trim(edt_BorrowDirectory.Text); 
48     FFtpServer.BorrowPort := StrToInt(Trim(edt_BorrowPort.Text)); 
49     FFtpServer.OnFtpNotifyEvent := TFTPServer1FtpNotifyEvent; 
50     FFtpServer.Run; 
51     mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP服务器已开启，本机IP地址：' + FFtpServer.GetBindingIP); 
52   end; 
53 end; 
54  
55 procedure TForm1.btn2Click(Sender: TObject); 
56 begin 
57   if Assigned(FFtpServer) then 
58   begin 
59     FFtpServer.Stop; 
60     FreeAndNil(FFtpServer); 
61     mmo1.Lines.Add(DateTimeToStr(Now) + #32 +'FTP服务器已关闭'); 
62   end; 
63 end; 
64  
65 procedure TForm1.TFTPServer1FtpNotifyEvent(ADatetime: TDateTime;AUserIP, AEventMessage: string); 
66 begin 
67   mmo1.Lines.Add(DateTimeToStr(ADatetime) + #32 + AUserIP + #32 + AEventMessage); 
68   SendMessage(mmo1.Handle,WM_VSCROLL,SB_PAGEDOWN,0); 
69 end; 
70 end.

结果如下图所示：

示例工程源码下载：

http://download.csdn.net/source/3236325

原博客地址：

http://blog.csdn.net/akof1314/article/details/6371984#comments

https://www.cnblogs.com/findumars/p/6360865.html

原文地址：https://www.cnblogs.com/jeremywucnblog/p/11427911.html