Delphi - Indy TIdFTPServer封装类 - Powered by Discuz! Archiver

功夫熊猫儿 發表於 2019-8-29 09:40:00

Delphi - Indy TIdFTPServer封装类

在Delphi 7开发下有强大的Indy控件，版本为9，要实现一个FTP服务器，参考自带的例子，发现还要写很多函数，而且不支持中文显示文件列表等等。
于是，自己改进封装了下，形成一个TFTPServer类。
源码如下：
<div class="postBody">
<div id="cnblogs_post_body" class="blogpost-body ">
<div class="cnblogs_code">
<pre>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 = '/' then
205 result := '/';
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 = '/' then
221 result := '/';
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 = '/' 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 <> '/' ) and ( old <> '/' ) 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.</pre>
</div>
使用工程示例：
<div>
<div class="cnblogs_code">
<pre> 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. </pre>
</div>
 
</div>
结果如下图所示：
<img src="http://hi.csdn.net/attachment/201104/29/0_1304059266Bx0Z.gif" alt="">
示例工程源码下载：
http://download.csdn.net/source/3236325
 
原博客地址：
http://blog.csdn.net/akof1314/article/details/6371984#comments
 
https://www.cnblogs.com/findumars/p/6360865.html
</div>
</div> 
来源：https://www.cnblogs.com/jeremywucnblog/p/11427911.html

頁: [1]

琼殿技术论坛's Archiver

Delphi - Indy TIdFTPServer封装类