在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
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. ![极其无聊的 StrtoDate 失败[图]](data:image/gif;base64,R0lGODlhAQABAIAAAP///wAAACwAAAAAAQABAAACAkQBADs=)