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
